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

Saladin

Altın Üye
Katılım
14 Ocak 2017
Mesajlar
43
Excel Vers. ve Dili
2010
Altın Üyelik Bitiş Tarihi
20-02-2026
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.
 

Ekli dosyalar

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,167
Excel Vers. ve Dili
2019 Türkçe
Merhaba.
Sayfa2'nin kod sayfasına kopyalayın.

Sayfa2'ye FİŞNO yazdıkça kodlar otomatik çalışacaktır
Kod:
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

Altın Üye
Katılım
14 Ocak 2017
Mesajlar
43
Excel Vers. ve Dili
2010
Altın Üyelik Bitiş Tarihi
20-02-2026
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

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,167
Excel Vers. ve Dili
2019 Türkçe
Sayfa2 de B kolonuna Fiş No yazdığınızda otomatik çalışacaktır.
 

Ekli dosyalar

Haluk

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
12,406
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Altın Üyelik Bitiş Tarihi
Alternatif;

C#:
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....



.
 

Ekli dosyalar

Son düzenleme:

Saladin

Altın Üye
Katılım
14 Ocak 2017
Mesajlar
43
Excel Vers. ve Dili
2010
Altın Üyelik Bitiş Tarihi
20-02-2026
Çok teşekkür ederim emeğinize sağlık.
 

Haluk

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
12,406
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Altın Üyelik Bitiş Tarihi
5 No'lu mesaj ekinde yer alan benim dosyayı da denediniz mi?

.
 

Saladin

Altın Üye
Katılım
14 Ocak 2017
Mesajlar
43
Excel Vers. ve Dili
2010
Altın Üyelik Bitiş Tarihi
20-02-2026
evet denedim çok teşekkür ederim.
 
Üst