Malzeme Açıklamalarının tek bir hücrede toplanması

[Saladin]

Merhaba Excel Web Ailesi,

Ekli tabloda bulunan Sayfa 2 deki malzeme açıklama bölümüne fatura numarasına göre Sayfa 1 de bulunan malzeme açıklamalarını,

ACS2023000000004 - (mazleme isimleri, aralarında virgül oalrak şekilde ) tek bir hücrede toplama imkanı varmıdır.

Şimdiden teşekkürler.

 

[Muzaffer Ali]

Merhaba.
Sayfa2'nin kod sayfasına kopyalayın.

Sayfa2'ye FİŞNO yazdıkça kodlar otomatik çalışacaktır

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Bak As Long
    Dim Bul As Range
    Dim Aciklama As String
    Dim Miktar As Double
    Dim Tutar As Double
    Dim NetTutar As Double
    Dim syf1 As Worksheet
    
    If Not Intersect(Target, Range("B:B")) Is Nothing Then
        Set syf1 = Worksheets("Sayfa1")
        Set Bul = syf1.Range("D1")
        Do
            Set Bul = syf1.Range("D" & Bul.Row + 1 & ":D" & Rows.Count).Find(what:=Target.Text, lookat:=xlWhole)
            If Bul Is Nothing Then
                Cells(Target.Row, "C") = Aciklama
                Cells(Target.Row, "D") = Miktar
                Cells(Target.Row, "E") = Tutar
                Cells(Target.Row, "F") = NetTutar
                Set Bul = syf1.Range("D1")
                Exit Do
            Else
                If Aciklama = "" Then
                    Aciklama = syf1.Cells(Bul.Row, "B")
                Else
                    Aciklama = Aciklama & ", " & syf1.Cells(Bul.Row, "B")
                End If
                Miktar = syf1.Cells(Bul.Row, "E")
                Tutar = syf1.Cells(Bul.Row, "P")
                NetTutar = syf1.Cells(Bul.Row, "Q")
            End If
        Loop
    End If
End Sub

 

[Saladin]

Merhaba muzaffer ali bey ilgili kodu sayfa 2 ye yazdım. fakar miktar ve tutar kısımlarında 0 çıkıyor ama malzeme içerikleri gelmiyor. hata yaptığımbir yer oalbilirmi.

 

[Muzaffer Ali]

Sayfa2 de B kolonuna Fiş No yazdığınızda otomatik çalışacaktır.

 

[Haluk]

Alternatif;

Sub Test()
'   Haluk - 22/03/2024
   
    Sheets("Sayfa2").Range("B2:C" & Rows.Count).ClearContents
      
    Set objConn = CreateObject("ADODB.Connection")
    Set RS = CreateObject("ADODB.RecordSet")

    strArgs = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)}; Readonly=False; DBQ=" & ThisWorkbook.FullName
    objConn.Open strArgs
  
    strSQL = "Select Distinct [FISNO] From [Sayfa1$]"
   
    Set RS = objConn.Execute(strSQL)
  
    Sheets("Sayfa2").Range("B2").CopyFromRecordset RS
   
    RS.Close
   
    For i = 2 To Sheets("Sayfa2").Range("B" & Rows.Count).End(xlUp).Row
        strSQL = "Select [MALZEMEACIKLAMA], [MIKTAR], [TUTAR], [NETTUTAR] From [Sayfa1$] Where [FISNO]= '" & Sheets("Sayfa2").Range("B" & i) & "'"
        Set RS = objConn.Execute(strSQL)

        Sheets("Sayfa2").Range("C" & i) = Join(Application.Index(RS.GetRows(, , "MALZEMEACIKLAMA"), 0), ", ")
        RS.MoVeFirst
        Sheets("Sayfa2").Range("D" & i) = Join(Application.Index(RS.GetRows(, , "MIKTAR"), 0), ", ")
        RS.MoVeFirst
        Sheets("Sayfa2").Range("E" & i) = Join(Application.Index(RS.GetRows(, , "TUTAR"), 0), ", ")
        RS.MoVeFirst
        Sheets("Sayfa2").Range("F" & i) = Join(Application.Index(RS.GetRows(, , "NETTUTAR"), 0), ", ")
       
        RS.Close
    Next
  
    objConn.Close
   
    Set RS = Nothing
    Set objConn = Nothing
End Sub

Örnek dosya da, bu mesaja eklenmiştir....



.

 

[Saladin]

Çok teşekkür ederim emeğinize sağlık.

 

[Haluk]

5 No'lu mesaj ekinde yer alan benim dosyayı da denediniz mi?

.

 

[Saladin]

evet denedim çok teşekkür ederim.