iki koşula bağlı olarak farklı satır ve sütun hücre değerlerini tek hücreye birleştir

K

khthonik

Katılım
27 Aralık 2010
Mesajlar
56
Excel Vers. ve Dili
Office 2010 TR 64 Bit
Merhabalar,

Açıklama: Kullanmakta olduğum araç takip excelimden alınan kesit sayfa1 resmindeki gibidir. Veri çekmek istediğim örnek kısım sayfa2 resmindeki gibidir.

İstenilen: sayfa2 resmideki J2 hücresine plakayı ve K2 hücresine araç kodunu yazdığım zaman L2 hücresine (Örnek olarak yazdığım gibi C, D, E, F, G hücrelerini aynyan aralarına x ve / koyarak birleştirsin) detayları tek hücre olarak hazırlasın.
J2 de Plaka ve K2 de araç kodunu değiştirirsem ona ait parça tanımı ve detayları L2 ye hazırlasın.




Saygılar
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,158
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Merhaba,

Sorunuzun çözümü için lütfen örnek dosyanızı ekleyiniz.
 
K

khthonik

Katılım
27 Aralık 2010
Mesajlar
56
Excel Vers. ve Dili
Office 2010 TR 64 Bit
Merhaba,

İlave seçeneklerde dosya ekleme kısmı çıkmadığı için dosyayı ekleyemedim.
İlgili excel ağda ortak kullanımda olduğundan ve firma özel bilgileri içerdiğinden dolayı gönderememekteyim. Excelde sayfa çok olduğu ve birbirinden veri çektikleri için sadece bu iki sayfayı alıp atayım dedim. Ama mevcut veriler gitti ve makrolar karıştı.
Aslında makroyu nasıl oluşturacağım konusunda bir kaç fikir ortaya atılsa, bende birşeyler katıp kendi sistemime entegre edebilirim diye düşünüyorum.

Excelimi şuanki satır ve sütunlarına göre anlatmak gerekirse;
SVKYTTF sayfasındaki J12:J21 ve K12:K21 sütunlarına girilen hücrelerdeki veriler SVKYT sayfasındaki D2:D500 ve S2:S500 sütunlarında varsa bu bilgilere karşılık gelen SVKYT sayfasındaki I,J,K,L,M,N sütunlarındaki verileri SVKYTTF sayfasındaki ilgili satırın F12:F21 sütunundaki hücresine "I1 K1xL1xM1-N1-J1 / I2 K2xL2xM2-N2-J2 / I3 K3xL3xM3-N3-J3 ...." şeklinde getirmesi isteniyor.

Umarım ifade edebilmişimdir.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,158
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Merhaba,

En azından sayfayı rastgele verilerle manuel hazırlayıp örnek dosyanızı paylaşım sitelerine yükleyip linkini forumda paylaşabilirsiniz. Orjinal dosyanızı göndermenize gerek yok.

Verilerle ilgili bilmemiz gereken bir detay varsa ayrıca belirtmenizi rica ederim.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,158
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Aşağıdaki kodu deneyiniz.

Kodu "SVKYTTF" isimli sayfanızın kod bölümüne uygulayınız.

A-B-C hücrelerindeki seçimleriniz tamamlanınca kod tepki verecektir.

Kod sonucunda E-F-G-H hücrelerine gerekli bilgiler gelecektir. Denemeler yapın sorun çıkarsa düzeltiriz.

Kod: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, X As Long, Veri As Range, Son As Long, Sonuc As String, Y As Long, Aciklama As String
    If Intersect(Target, Range("A12:C21")) Is Nothing Then Exit Sub
    Set S1 = Sheets("SVKYT")
    X = Target.Row
    If WorksheetFunction.CountA(Range("A" & X & ":C" & X)) = 3 Then
        Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
        For Each Veri In S1.Range("C2:C" & Son)
            If Veri.Value = Cells(X, "A") Then
                If Veri.Offset(0, 1).Value = Cells(X, "B") Then
                    If Veri.Offset(0, 16).Value = Cells(X, "C") Then
                        Cells(X, "E") = Veri.Offset(0, 15).Value
                        If Veri.Offset(0, 16).MergeCells Then
                            For Y = Veri.Row To Veri.Row + Veri.Offset(0, 16).MergeArea.Count - 1
                                If Sonuc = "" Then
                                    Sonuc = S1.Cells(Y, "I") & " " & S1.Cells(Y, "K") & "x" & S1.Cells(Y, "L") & "x" & _
                                            S1.Cells(Y, "M") & "-" & S1.Cells(Y, "N") & "-" & S1.Cells(Y, "J")
                                    If S1.Cells(Y, "T") <> "" Then Aciklama = S1.Cells(Y, "T")
                                Else
                                    Sonuc = Sonuc & " / " & S1.Cells(Y, "I") & " " & S1.Cells(Y, "K") & "x" & S1.Cells(Y, "L") & "x" & _
                                            S1.Cells(Y, "M") & "-" & S1.Cells(Y, "N") & "-" & S1.Cells(Y, "J")
                                    If S1.Cells(Y, "T") <> "" Then Aciklama = Aciklama & " / " & S1.Cells(Y, "T")
                                End If
                            Next
                            
                            Cells(X, "F") = Sonuc
                            Cells(X, "G") = Aciklama
                            Cells(X, "H") = Veri.Offset(0, 12).Value
                            Sonuc = ""
                            Aciklama = ""
                        End If
                    End If
                End If
            End If
        Next
    End If
End Sub
 
K

khthonik

Katılım
27 Aralık 2010
Mesajlar
56
Excel Vers. ve Dili
Office 2010 TR 64 Bit
Korhan Bey,

Çok teşekkür ederim.

Saygılar..
 
K

khthonik

Katılım
27 Aralık 2010
Mesajlar
56
Excel Vers. ve Dili
Office 2010 TR 64 Bit
Korhan Bey,

Kırmızı yazıyla belirttiklerimi ben ekledim (her iki sayfada hem gizli hemde sayfa korumalı olduğu için)

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim S1 As Worksheet, X As Long, Veri As Range, Son As Long, Sonuc As String, Y As Long, Aciklama As String
If Intersect(Target, Range("A12:C21")) Is Nothing Then Exit Sub
Set S1 = Sheets("SVKYT")

Application.ScreenUpdating = False
ActiveSheet.Unprotect Password:="EYS"

X = Target.Row
If WorksheetFunction.CountA(Range("A" & X & ":C" & X)) = 3 Then
Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
For Each Veri In S1.Range("C2:C" & Son)
If Veri.Value = Cells(X, "A") Then
If Veri.Offset(0, 1).Value = Cells(X, "B") Then
If Veri.Offset(0, 16).Value = Cells(X, "C") Then
Cells(X, "E") = Veri.Offset(0, 15).Value
If Veri.Offset(0, 16).MergeCells Then
For Y = Veri.Row To Veri.Row + Veri.Offset(0, 16).MergeArea.Count - 1
If Sonuc = "" Then
Sonuc = S1.Cells(Y, "I") & " " & S1.Cells(Y, "K") & "x" & S1.Cells(Y, "L") & "x" & _
S1.Cells(Y, "M") & "-" & S1.Cells(Y, "N") & "-" & S1.Cells(Y, "J")
If S1.Cells(Y, "T") <> "" Then Aciklama = S1.Cells(Y, "T")
Else
Sonuc = Sonuc & " / " & S1.Cells(Y, "I") & " " & S1.Cells(Y, "K") & "x" & S1.Cells(Y, "L") & "x" & _
S1.Cells(Y, "M") & "-" & S1.Cells(Y, "N") & "-" & S1.Cells(Y, "J")
If S1.Cells(Y, "T") <> "" Then Aciklama = Aciklama & " / " & S1.Cells(Y, "T")
End If
Next

Cells(X, "F") = Sonuc
Cells(X, "G") = Aciklama
Cells(X, "H") = Veri.Offset(0, 12).Value
Sonuc = ""
Aciklama = ""
End If
End If
End If
End If
Next
End If

Rows("12:21").EntireRow.AutoFit
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True, Password:="EYS", AllowInsertingRows:=True _
, AllowFormattingRows:=True, AllowDeletingRows:=True

End Sub

SVKYT sayfasında tek satır olan araçların (çünkü bu araçların başka malzemesi yoktur) bilgilerini, SVKYTTF sayfasındaki E-F-G-H hücrelerine getirmiyor.

Saygılar
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,158
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

Kod: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, X As Long, Veri As Range, Son As Long, Sonuc As String, Y As Long, Aciklama As String
    If Intersect(Target, Range("A12:C21")) Is Nothing Then Exit Sub
    Set S1 = Sheets("SVKYT")
    
    Application.ScreenUpdating = False
    ActiveSheet.Unprotect Password:="EYS"
    
    X = Target.Row
    If WorksheetFunction.CountA(Range("A" & X & ":C" & X)) = 3 Then
        Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
        For Each Veri In S1.Range("C2:C" & Son)
            If Veri.Value = Cells(X, "A") Then
                If Veri.Offset(0, 1).Value = Cells(X, "B") Then
                    If Veri.Offset(0, 16).Value = Cells(X, "C") Then
                        Cells(X, "E") = Veri.Offset(0, 15).Value
                        If Veri.Offset(0, 16).MergeCells Then
                            For Y = Veri.Row To Veri.Row + Veri.Offset(0, 16).MergeArea.Count - 1
                                If Sonuc = "" Then
                                    Sonuc = S1.Cells(Y, "I") & " " & S1.Cells(Y, "K") & "x" & S1.Cells(Y, "L") & "x" & _
                                            S1.Cells(Y, "M") & "-" & S1.Cells(Y, "N") & "-" & S1.Cells(Y, "J")
                                    If S1.Cells(Y, "T") <> "" Then Aciklama = S1.Cells(Y, "T")
                                Else
                                    Sonuc = Sonuc & " / " & S1.Cells(Y, "I") & " " & S1.Cells(Y, "K") & "x" & S1.Cells(Y, "L") & "x" & _
                                            S1.Cells(Y, "M") & "-" & S1.Cells(Y, "N") & "-" & S1.Cells(Y, "J")
                                    If S1.Cells(Y, "T") <> "" Then Aciklama = Aciklama & " / " & S1.Cells(Y, "T")
                                End If
                            Next
                            
                            Cells(X, "F") = Sonuc
                            Cells(X, "G") = Aciklama
                            Cells(X, "H") = Veri.Offset(0, 12).Value
                        Else
                            For Y = Veri.Row To Veri.Row + Veri.Offset(0, 16).MergeArea.Count - 1
                                If Sonuc = "" Then
                                    Sonuc = S1.Cells(Y, "I") & " " & S1.Cells(Y, "K") & "x" & S1.Cells(Y, "L") & "x" & _
                                            S1.Cells(Y, "M") & "-" & S1.Cells(Y, "N") & "-" & S1.Cells(Y, "J")
                                    If S1.Cells(Y, "T") <> "" Then Aciklama = S1.Cells(Y, "T")
                                Else
                                    Sonuc = Sonuc & " / " & S1.Cells(Y, "I") & " " & S1.Cells(Y, "K") & "x" & S1.Cells(Y, "L") & "x" & _
                                            S1.Cells(Y, "M") & "-" & S1.Cells(Y, "N") & "-" & S1.Cells(Y, "J")
                                    If S1.Cells(Y, "T") <> "" Then Aciklama = Aciklama & " / " & S1.Cells(Y, "T")
                                End If
                            Next
                            
                            Cells(X, "F") = Sonuc
                            Cells(X, "G") = Aciklama
                            Cells(X, "H") = Veri.Offset(0, 12).Value
                        End If
                        Sonuc = ""
                        Aciklama = ""
                    End If
                End If
            End If
        Next
    End If
    Rows("12:21").EntireRow.AutoFit
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
    , AllowFiltering:=True, Password:="EYS", AllowInsertingRows:=True _
    , AllowFormattingRows:=True, AllowDeletingRows:=True
    Application.ScreenUpdating = True
End Sub
 
K

khthonik

Katılım
27 Aralık 2010
Mesajlar
56
Excel Vers. ve Dili
Office 2010 TR 64 Bit
Merhaba,

Korhan Bey öncelikle ilgi ve alakanıza çok teşekkür ederim. Bu konu ile ilgi bir şey daha isteyebilir miyim.
SVKYT sayfasında U sütununda Ok yazıyorsa tüm bu işlemleri yapsın. Yazmıyorsa SVKYT sayfası U sütununu kontrol ediniz diye mesaj versin.

Saygılar
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst