Aynı Ölçüleri Eşleme

mc_exrem

Altın Üye
Katılım
25 Mayıs 2010
Mesajlar
477
Excel Vers. ve Dili
Office 2019
64bit
Tr
Win 10
Merhabalar üstadlar,

Dosyamın CAM sayfasında bulunan aynı ölçüdeki camları adetleriyle birlikte başka bir sayfaya eşleyerek aktarmak istiyorum.
Yani 11 ve 12 satırdaki ölçülerin eni ve boyu aynı, 11. satırdaki adetin üzerine diğer satırlardaki aynı ölçüleri adetleri ile ekleyerek tek ölçü yapmasını istiyorum.
Yani sayfada eni ve boyu aynı olan tek satır olsun istiyorum.
Bu çalışma Sürekli olarak ölçü yazdığım bir sayfa olduğu için ölçülerin değiştirilebilir olacağını ve daha sonra farklı ölçüler girileceğini göz önünde bulundurarak işlem yapmanızı rica ederim.

Yardımlarınız için teşekkür eder saygılar sunarım.
 

Ekli dosyalar

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,553
Excel Vers. ve Dili
Pro Plus 2021
Kod:
Sub test()

    Dim i&, son&, kys, itms, z(1 To 1, 1 To 2), w

    Sheets("C A M").Select
    Range("J11.R" & Rows.Count).Clear

    With CreateObject("Scripting.Dictionary")
        son = Cells(Rows.Count, 1).End(3).Row
        For i = 11 To son
            ky = Cells(i, "B").Value & "|" & Cells(i, "C").Value
            If .exists(ky) Then
                w = .Item(ky)
                w(1, 1) = w(1, 1) + Cells(i, "A").Value
                w(1, 2) = w(1, 2) + Cells(i, "G").Value
                .Item(ky) = w
            Else
                z(1, 1) = Cells(i, "A").Value
                z(1, 2) = Cells(i, "G").Value
                .Item(ky) = z
            End If
        Next i
        kys = .keys
        itms = .items
        For i = 0 To UBound(kys)
            Cells(i + 11, "J").Resize(, 2).Value = Split(kys(i), "|")
            Cells(i + 11, "L").Resize(, 2).Value = itms(i)
            Cells(i + 11, "J").Value = Cells(i + 11, "J").Value * 1
            Cells(i + 11, "K").Value = Cells(i + 11, "K").Value * 1
            If Cells(i + 11, "M").Value = 0 Then Cells(i + 11, "M").ClearContents
        Next i
    End With
    Cells(9, "J").Resize(, 4).Value = Array("EN", "BOY", "ADET", "İŞLEM")
    Range("J11.M" & Rows.Count).Sort [j11], xlDescending, [k11], , xlDescending, , xlAscending, xlNo
End Sub
 

mc_exrem

Altın Üye
Katılım
25 Mayıs 2010
Mesajlar
477
Excel Vers. ve Dili
Office 2019
64bit
Tr
Win 10
Kod:
Sub test()

    Dim i&, son&, kys, itms, z(1 To 1, 1 To 2), w

    Sheets("C A M").Select
    Range("J11.R" & Rows.Count).Clear

    With CreateObject("Scripting.Dictionary")
        son = Cells(Rows.Count, 1).End(3).Row
        For i = 11 To son
            ky = Cells(i, "B").Value & "|" & Cells(i, "C").Value
            If .exists(ky) Then
                w = .Item(ky)
                w(1, 1) = w(1, 1) + Cells(i, "A").Value
                w(1, 2) = w(1, 2) + Cells(i, "G").Value
                .Item(ky) = w
            Else
                z(1, 1) = Cells(i, "A").Value
                z(1, 2) = Cells(i, "G").Value
                .Item(ky) = z
            End If
        Next i
        kys = .keys
        itms = .items
        For i = 0 To UBound(kys)
            Cells(i + 11, "J").Resize(, 2).Value = Split(kys(i), "|")
            Cells(i + 11, "L").Resize(, 2).Value = itms(i)
            Cells(i + 11, "J").Value = Cells(i + 11, "J").Value * 1
            Cells(i + 11, "K").Value = Cells(i + 11, "K").Value * 1
            If Cells(i + 11, "M").Value = 0 Then Cells(i + 11, "M").ClearContents
        Next i
    End With
    Cells(9, "J").Resize(, 4).Value = Array("EN", "BOY", "ADET", "İŞLEM")
    Range("J11.M" & Rows.Count).Sort [j11], xlDescending, [k11], , xlDescending, , xlAscending, xlNo
End Sub
İlginiz için teşekkür ederim. Yoğunluktan anca yazabildim kusurum affola. Kodu çalıştıramadım çünki verileri boş bir sayfaya eşleyerek aktaracağım. Yarın güncel listeyi ekleyeceğim. Teşekkürler.
 

mc_exrem

Altın Üye
Katılım
25 Mayıs 2010
Mesajlar
477
Excel Vers. ve Dili
Office 2019
64bit
Tr
Win 10
Kod:
Sub test()

    Dim i&, son&, kys, itms, z(1 To 1, 1 To 2), w

    Sheets("C A M").Select
    Range("J11.R" & Rows.Count).Clear

    With CreateObject("Scripting.Dictionary")
        son = Cells(Rows.Count, 1).End(3).Row
        For i = 11 To son
            ky = Cells(i, "B").Value & "|" & Cells(i, "C").Value
            If .exists(ky) Then
                w = .Item(ky)
                w(1, 1) = w(1, 1) + Cells(i, "A").Value
                w(1, 2) = w(1, 2) + Cells(i, "G").Value
                .Item(ky) = w
            Else
                z(1, 1) = Cells(i, "A").Value
                z(1, 2) = Cells(i, "G").Value
                .Item(ky) = z
            End If
        Next i
        kys = .keys
        itms = .items
        For i = 0 To UBound(kys)
            Cells(i + 11, "J").Resize(, 2).Value = Split(kys(i), "|")
            Cells(i + 11, "L").Resize(, 2).Value = itms(i)
            Cells(i + 11, "J").Value = Cells(i + 11, "J").Value * 1
            Cells(i + 11, "K").Value = Cells(i + 11, "K").Value * 1
            If Cells(i + 11, "M").Value = 0 Then Cells(i + 11, "M").ClearContents
        Next i
    End With
    Cells(9, "J").Resize(, 4).Value = Array("EN", "BOY", "ADET", "İŞLEM")
    Range("J11.M" & Rows.Count).Sort [j11], xlDescending, [k11], , xlDescending, , xlAscending, xlNo
End Sub
merhabalar

aktarılması gereken EŞLEME sayfası eklendi.
CAM sayfasındaki gibi A11 hücresinden başlayarak ölçü ve adetleri atması için yardımcı olur musunuz

denedim ama resimdeki hatayı verdi.
228236
228237
 

Ekli dosyalar

Son düzenleme:

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,553
Excel Vers. ve Dili
Pro Plus 2021
Kodları module içerisine yerleştirin.
Kod:
Sub test()
    Dim s1 As Worksheet, s2 As Worksheet
    Dim i&, son&, sat&, ky$
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Set s1 = Sheets("C A M")
    Set s2 = Sheets("EŞLEME")
    s2.Range("A11:Z" & Rows.Count).Clear
    son = s1.Cells(Rows.Count, 1).End(3).Row
    s1.Range("A11:H" & son).Copy s2.Range("A11")
    s2.Select
    For i = son To 11 Step -1
        If Cells(i, "H").Value <> "" Then
            Cells(i, "H").Value = Replace(Cells(i, "H").Value, " SONU", "")
            Cells(i, "H").Value = Replace(Cells(i, "H").Value, " ", "")
            ky = Replace(Cells(i, "H").Value, " SONU", "")
        Else
            Cells(i, "H").Value = ky
        End If
    Next i

    With CreateObject("Scripting.Dictionary")
        For i = 11 To son
            ky = Cells(i, "B").Value & "|" & Cells(i, "C").Value
            If Cells(i, "G").Value <> "" Then ky = ky & "|" & Cells(i, "B").Value & "|" & Cells(i, "C").Value
            If Not .exists(ky) Then
                .Item(ky) = i
                Cells(i, "D").FormulaR1C1 = "=RC[-2]*RC[-1]/1000000"
                    Cells(i, "H").Value = Cells(i, "A").Value & "x" & Cells(i, "H").Value
            Else
                sat = .Item(ky)
                Cells(sat, "A") = Cells(sat, "A") + Cells(i, "A").Value
                If Cells(i, "G").Value <> "" Then Cells(sat, "G") = Cells(sat, "G") + Cells(i, "G").Value

                    Cells(sat, "H").Value = Cells(sat, "H").Value & " | " & Cells(i, "A").Value & "x" & Cells(i, "H").Value
                Cells(i, "A").Resize(, 8).ClearContents
            End If
        Next i
    End With

    Range("A11:H" & Rows.Count).Sort [D11], xlDescending, [C11], , xlDescending, [B11], xlDescending, xlNo
    son = Cells(Rows.Count, 1).End(3).Row
    Range("A" & son + 1 & ":H" & Rows.Count).Delete xlUp
    Range("D11:D" & son).ClearContents
    Range("K2").Formula = "=SUM(G11:G" & son & ")"
    Range("A8").Formula = "=SUM(A11:A" & son & ")"
    Range("D8").Formula = "=SUM(E11:E" & son & ")"

    Range("A11:H11").Copy
    Range("A12:H" & son).PasteSpecial xlPasteFormats
    
        For i = 11 To son - 1
            If Cells(i, "B").Value = Cells(i + 1, "B").Value And _
            Cells(i, "C").Value = Cells(i + 1, "C").Value Then
            Cells(i, "A").Resize(2, 7).Interior.Color = vbYellow
            End If
        Next i
    
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
 
Son düzenleme:

mc_exrem

Altın Üye
Katılım
25 Mayıs 2010
Mesajlar
477
Excel Vers. ve Dili
Office 2019
64bit
Tr
Win 10
Kodları module içerisine yerleştirin.
Kod:
Sub test()
    Dim s1 As Worksheet, s2 As Worksheet
    Dim i&, son&, sat&, ky$
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Set s1 = Sheets("C A M")
    Set s2 = Sheets("EŞLEME")
    s2.Range("A11.Z" & Rows.Count).Clear
    son = s1.Cells(Rows.Count, 1).End(3).Row
    s1.Range("A11:H" & son).Copy s2.Range("A11")
    s2.Select
    For i = son To 11 Step -1
        If Cells(i, "H").Value <> "" Then
            Cells(i, "H").Value = Replace(Cells(i, "H").Value, " SONU", "")
            Cells(i, "H").Value = Replace(Cells(i, "H").Value, " ", "")
            ky = Replace(Cells(i, "H").Value, " SONU", "")
        Else
            Cells(i, "H").Value = ky
        End If
    Next i

    With CreateObject("Scripting.Dictionary")
        For i = 11 To son
            ky = Cells(i, "B").Value & "|" & Cells(i, "C").Value
            If Cells(i, "G").Value <> "" Then ky = ky & "|" & Cells(i, "B").Value & "|" & Cells(i, "C").Value
            If Not .exists(ky) Then
                .Item(ky) = i
                Cells(i, "D").FormulaR1C1 = "=RC[-2]*RC[-1]/1000000"
                    Cells(i, "H").Value = Cells(i, "A").Value & "x" & Cells(i, "H").Value
            Else
                sat = .Item(ky)
                Cells(sat, "A") = Cells(sat, "A") + Cells(i, "A").Value
                If Cells(i, "G").Value <> "" Then Cells(sat, "G") = Cells(sat, "G") + Cells(i, "G").Value

                    Cells(sat, "H").Value = Cells(sat, "H").Value & " | " & Cells(i, "A").Value & "x" & Cells(i, "H").Value
                Cells(i, "A").Resize(, 8).ClearContents
            End If
        Next i
    End With

    Range("A11.H" & Rows.Count).Sort [D11], xlDescending, [C11], , xlDescending, [B11], xlDescending, xlNo
    son = Cells(Rows.Count, 1).End(3).Row
    Range("A" & son + 1 & ":H" & Rows.Count).Delete xlUp
    Range("D11:D" & son).ClearContents
    Range("K2").Formula = "=SUM(G11:G" & son & ")"
    Range("A8").Formula = "=SUM(A11:A" & son & ")"
    Range("D8").Formula = "=SUM(E11:E" & son & ")"

    Range("A11:H11").Copy
    Range("A12:H" & son).PasteSpecial xlPasteFormats
  
        For i = 11 To son - 1
            If Cells(i, "B").Value = Cells(i + 1, "B").Value And _
            Cells(i, "C").Value = Cells(i + 1, "C").Value Then
            Cells(i, "A").Resize(2, 7).Interior.Color = vbYellow
            End If
        Next i
     
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
Teşekkürler
Yarın deneyip akıbetini paylaşacağım.
İyi akşamlar
 

mc_exrem

Altın Üye
Katılım
25 Mayıs 2010
Mesajlar
477
Excel Vers. ve Dili
Office 2019
64bit
Tr
Win 10
Kodları module içerisine yerleştirin.
Kod:
Sub test()
    Dim s1 As Worksheet, s2 As Worksheet
    Dim i&, son&, sat&, ky$
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Set s1 = Sheets("C A M")
    Set s2 = Sheets("EŞLEME")
    s2.Range("A11.Z" & Rows.Count).Clear
    son = s1.Cells(Rows.Count, 1).End(3).Row
    s1.Range("A11:H" & son).Copy s2.Range("A11")
    s2.Select
    For i = son To 11 Step -1
        If Cells(i, "H").Value <> "" Then
            Cells(i, "H").Value = Replace(Cells(i, "H").Value, " SONU", "")
            Cells(i, "H").Value = Replace(Cells(i, "H").Value, " ", "")
            ky = Replace(Cells(i, "H").Value, " SONU", "")
        Else
            Cells(i, "H").Value = ky
        End If
    Next i

    With CreateObject("Scripting.Dictionary")
        For i = 11 To son
            ky = Cells(i, "B").Value & "|" & Cells(i, "C").Value
            If Cells(i, "G").Value <> "" Then ky = ky & "|" & Cells(i, "B").Value & "|" & Cells(i, "C").Value
            If Not .exists(ky) Then
                .Item(ky) = i
                Cells(i, "D").FormulaR1C1 = "=RC[-2]*RC[-1]/1000000"
                    Cells(i, "H").Value = Cells(i, "A").Value & "x" & Cells(i, "H").Value
            Else
                sat = .Item(ky)
                Cells(sat, "A") = Cells(sat, "A") + Cells(i, "A").Value
                If Cells(i, "G").Value <> "" Then Cells(sat, "G") = Cells(sat, "G") + Cells(i, "G").Value

                    Cells(sat, "H").Value = Cells(sat, "H").Value & " | " & Cells(i, "A").Value & "x" & Cells(i, "H").Value
                Cells(i, "A").Resize(, 8).ClearContents
            End If
        Next i
    End With

    Range("A11.H" & Rows.Count).Sort [D11], xlDescending, [C11], , xlDescending, [B11], xlDescending, xlNo
    son = Cells(Rows.Count, 1).End(3).Row
    Range("A" & son + 1 & ":H" & Rows.Count).Delete xlUp
    Range("D11:D" & son).ClearContents
    Range("K2").Formula = "=SUM(G11:G" & son & ")"
    Range("A8").Formula = "=SUM(A11:A" & son & ")"
    Range("D8").Formula = "=SUM(E11:E" & son & ")"

    Range("A11:H11").Copy
    Range("A12:H" & son).PasteSpecial xlPasteFormats
  
        For i = 11 To son - 1
            If Cells(i, "B").Value = Cells(i + 1, "B").Value And _
            Cells(i, "C").Value = Cells(i + 1, "C").Value Then
            Cells(i, "A").Resize(2, 7).Interior.Color = vbYellow
            End If
        Next i
     
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
merhabalar
modele4 e ekledim ama aşağıdaki hatayı verdi.

228254

228255
 

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,610
Excel Vers. ve Dili
Microsoft 365 Tr-64
s2.Range("A11:Z" & Rows.Count).Clear

iki noktaya dikkat edin :
 

mc_exrem

Altın Üye
Katılım
25 Mayıs 2010
Mesajlar
477
Excel Vers. ve Dili
Office 2019
64bit
Tr
Win 10
evet aktardı

kontrol ediyorum
 

mc_exrem

Altın Üye
Katılım
25 Mayıs 2010
Mesajlar
477
Excel Vers. ve Dili
Office 2019
64bit
Tr
Win 10
Kodları module içerisine yerleştirin.
Kod:
Sub test()
    Dim s1 As Worksheet, s2 As Worksheet
    Dim i&, son&, sat&, ky$
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Set s1 = Sheets("C A M")
    Set s2 = Sheets("EŞLEME")
    s2.Range("A11:Z" & Rows.Count).Clear
    son = s1.Cells(Rows.Count, 1).End(3).Row
    s1.Range("A11:H" & son).Copy s2.Range("A11")
    s2.Select
    For i = son To 11 Step -1
        If Cells(i, "H").Value <> "" Then
            Cells(i, "H").Value = Replace(Cells(i, "H").Value, " SONU", "")
            Cells(i, "H").Value = Replace(Cells(i, "H").Value, " ", "")
            ky = Replace(Cells(i, "H").Value, " SONU", "")
        Else
            Cells(i, "H").Value = ky
        End If
    Next i

    With CreateObject("Scripting.Dictionary")
        For i = 11 To son
            ky = Cells(i, "B").Value & "|" & Cells(i, "C").Value
            If Cells(i, "G").Value <> "" Then ky = ky & "|" & Cells(i, "B").Value & "|" & Cells(i, "C").Value
            If Not .exists(ky) Then
                .Item(ky) = i
                Cells(i, "D").FormulaR1C1 = "=RC[-2]*RC[-1]/1000000"
                    Cells(i, "H").Value = Cells(i, "A").Value & "x" & Cells(i, "H").Value
            Else
                sat = .Item(ky)
                Cells(sat, "A") = Cells(sat, "A") + Cells(i, "A").Value
                If Cells(i, "G").Value <> "" Then Cells(sat, "G") = Cells(sat, "G") + Cells(i, "G").Value

                    Cells(sat, "H").Value = Cells(sat, "H").Value & " | " & Cells(i, "A").Value & "x" & Cells(i, "H").Value
                Cells(i, "A").Resize(, 8).ClearContents
            End If
        Next i
    End With

    Range("A11:H" & Rows.Count).Sort [D11], xlDescending, [C11], , xlDescending, [B11], xlDescending, xlNo
    son = Cells(Rows.Count, 1).End(3).Row
    Range("A" & son + 1 & ":H" & Rows.Count).Delete xlUp
    Range("D11:D" & son).ClearContents
    Range("K2").Formula = "=SUM(G11:G" & son & ")"
    Range("A8").Formula = "=SUM(A11:A" & son & ")"
    Range("D8").Formula = "=SUM(E11:E" & son & ")"

    Range("A11:H11").Copy
    Range("A12:H" & son).PasteSpecial xlPasteFormats
   
        For i = 11 To son - 1
            If Cells(i, "B").Value = Cells(i + 1, "B").Value And _
            Cells(i, "C").Value = Cells(i + 1, "C").Value Then
            Cells(i, "A").Resize(2, 7).Interior.Color = vbYellow
            End If
        Next i
   
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
Emeğinize sağlık makroyu çalıştırınca eşlemeleri yaptı ancak cevap yazabildim iş yoğunluğu malum.
Bir sıkıntımız var o da eşlenen verilerdeki satırlar boş kalıyor ve bu şekilde de çıktı alamıyorum. Yani diğer berinin adedine eklenen ölçülerin olduğu satır boş kalıyor.
Sizden ricam eşleme yapıldıktan sonra boş satırın kalmaması.
Yardımcı olabilir misiniz?
 
Üst