Aynı Ölçüleri Eşleme

mc_exrem

mc_exrem

Katılım
25 Mayıs 2010
Mesajlar
480
Excel Vers. ve Dili
Office 2019
64bit
Tr
Win 10
Altın Üyelik Bitiş Tarihi
12-07-2024
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

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,647
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

mc_exrem

Katılım
25 Mayıs 2010
Mesajlar
480
Excel Vers. ve Dili
Office 2019
64bit
Tr
Win 10
Altın Üyelik Bitiş Tarihi
12-07-2024
veyselemre' Alıntı:
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
Genişletmek için tıkla ...
İ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

mc_exrem

Katılım
25 Mayıs 2010
Mesajlar
480
Excel Vers. ve Dili
Office 2019
64bit
Tr
Win 10
Altın Üyelik Bitiş Tarihi
12-07-2024
veyselemre' Alıntı:
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
Genişletmek için tıkla ...
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

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,647
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

mc_exrem

Katılım
25 Mayıs 2010
Mesajlar
480
Excel Vers. ve Dili
Office 2019
64bit
Tr
Win 10
Altın Üyelik Bitiş Tarihi
12-07-2024
veyselemre' Alıntı:
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
Genişletmek için tıkla ...
Teşekkürler
Yarın deneyip akıbetini paylaşacağım.
İyi akşamlar
 
mc_exrem

mc_exrem

Katılım
25 Mayıs 2010
Mesajlar
480
Excel Vers. ve Dili
Office 2019
64bit
Tr
Win 10
Altın Üyelik Bitiş Tarihi
12-07-2024
veyselemre' Alıntı:
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
Genişletmek için tıkla ...
merhabalar
modele4 e ekledim ama aşağıdaki hatayı verdi.

228254

228255
 
ÖmerFaruk

ÖmerFaruk

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

iki noktaya dikkat edin :
 
mc_exrem

mc_exrem

Katılım
25 Mayıs 2010
Mesajlar
480
Excel Vers. ve Dili
Office 2019
64bit
Tr
Win 10
Altın Üyelik Bitiş Tarihi
12-07-2024
evet aktardı

kontrol ediyorum
 
mc_exrem

mc_exrem

Katılım
25 Mayıs 2010
Mesajlar
480
Excel Vers. ve Dili
Office 2019
64bit
Tr
Win 10
Altın Üyelik Bitiş Tarihi
12-07-2024
veyselemre' Alıntı:
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
Genişletmek için tıkla ...
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?
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst