Adet kadar satır çoğalt

[ADER_34]

Merhaba hayırlı geceler arkadaşlar ben 2 sayfa arasında sayfa1 "A" sütunu sabit
sayfa2 sütunlar değişken olabilir, sayfa1 "A" sütununu say, sayfa2 de eşleştir,
sayfa2 de bulduklarının adet sütunda adeti kadar yeni sayfa açarak kopyala..
"sayfa1" partno: 90NK0010-R00030
"sayfa2: partno: 90NK0010-R00030 adet: 4
sonuç sayfa3: partno: 90NK0010-R00030
90NK0010-R00030
90NK0010-R00030
90NK0010-R00030
olmalı mümkün mü kolay gelsin teşekkürler..

http://s9.dosya.tc/server/zxj7kf/ADET_SATIR_OK.xlsx.html

 

[YUSUF44]

Dosyanızda Sayfa1 ve Sayfa2 yok, Sayfa3 de yok. ANALİSTE ve TÜM LİSTE sayfaları var. Her iki sayfada da aynı kodlar ve sayılar var. R00030'dan 4 adet demişsiniz ama dosyada her iki sayfada da 15 adet yazıyor.
Kısacası yazdıklarınızla dosyanız uyumlu değil maalesef. Ayrıca anlattıklarınızdan da tam olarak ne istediğinizi anlayamadım.
Sorunuzu örnek dosyanızla uyumlu olarak ve tam olarak ne istediğinizi bizim anlayabileceğimiz şekilde anlatarak tekrar sorar mısınız?

 

[ADER_34]

Merhaba sayın Yusuf44 aslında kısaca şöyle ANALİSTE de "A" sütununda benzersiz değerleri TÜMLİSTE de say eşleşenlerin " TÜMLİSTE" sayfasında ki adetlerine bak, eşleşen veri adeti kadar
yeni sayfa açarak kopyala

http://s9.dosya.tc/server/n1xoya/ADET_SATIR_2.xlsx.html
Örnek dosyamı düzelltim bakarsanız sevinirim kolay gelsin teşekkürler..

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub SAYFALARA_AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim X As Long, Son As Long, Bul As Range, Adet As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("ANALİSTE")
    Set S2 = Sheets("TÜM LİSTE")
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    
    For X = 2 To Son
        If S1.Cells(X, 1) <> "" Then
            If WorksheetFunction.CountIf(S1.Range("A1:A" & X), S1.Cells(X, 1)) = 1 Then
                Set Bul = S2.Range("A:A").Find(S1.Cells(X, 1), , , xlWhole)
                If Not Bul Is Nothing Then
                    Adet = Bul.Offset(0, 2)
                    If Adet > 0 Then
                        Set S3 = Nothing
                        On Error Resume Next
                        Set S3 = Sheets(S1.Cells(X, 1).Value)
                        On Error GoTo 0
                        If S3 Is Nothing Then
                            Set S3 = Sheets.Add(, Sheets(Worksheets.Count))
                            S3.Name = S1.Cells(X, 1)
                            S3.Range("A1:F1") = Array("PN", "", "", "", "", "ADET")
                            S3.Range("A1:F1").Font.Bold = True
                            S3.Range("A1:F1").Font.Size = 14
                            S3.Range("A1:F1").HorizontalAlignment = xlCenter
                            S3.Range("A1:F1").Interior.ColorIndex = 6
                            S3.Range("A2:A" & Adet + 1) = S1.Cells(X, 1)
                            S3.Range("F2:F" & Adet + 1) = Adet
                            S3.Range("A1:F" & Adet + 1).Borders.LineStyle = 1
                            S3.Cells.EntireColumn.AutoFit
                        End If
                    End If
                End If
            End If
        End If
    Next
    
    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[ADER_34]

Merhaba Korhan Bey kodlarınızı denedim yapmak istediğime yakın bir sonuç herşey olumlu fakat
tek sorun kodlar tek tek sayfa açmayıp, değerleri tek sayfada "SONUÇ" sayfasında alt alta toplamalı bakabilirmisiniz teşekkürler kolay gelsin..
size dosyamın net halini tekrar yollu yorum bakarsanız sevinirim..

http://s9.dosya.tc/server/t3sfqo/ADET_SATIR_3.xlsx.html

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub SAYFALARA_AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim X As Long, Son As Long, Bul As Range, Adet As Long, Satir As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("ANALİSTE")
    Set S2 = Sheets("TÜM LİSTE")
    Set S3 = Sheets("SONUÇ")
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    S3.Range("A2:F" & S3.Rows.Count).ClearContents
    S3.Cells.Font.Name = "Calibri"
    S3.Cells.Font.Size = 14
    S3.Range("A:A,F:F").Font.Bold = True
    S3.Range("A:A,F:F").HorizontalAlignment = xlCenter
    Satir = 2
    
    For X = 2 To Son
        If S1.Cells(X, 1) <> "" Then
            If WorksheetFunction.CountIf(S1.Range("A1:A" & X), S1.Cells(X, 1)) = 1 Then
                Set Bul = S2.Range("A:A").Find(S1.Cells(X, 1), , , xlWhole)
                If Not Bul Is Nothing Then
                    Adet = Bul.Offset(0, 2)
                    If Adet > 0 Then
                        S3.Range("A" & Satir & ":A" & Satir + Adet - 1) = S1.Cells(X, 1)
                        S3.Range("F" & Satir & ":F" & Satir + Adet - 1) = Adet
                        S3.Cells.EntireColumn.AutoFit
                        Satir = S3.Cells(S3.Rows.Count, 1).End(3).Row + 1
                    End If
                End If
            End If
        End If
    Next
    
    S3.Range("A1:F" & Satir - 1).Borders.LineStyle = 1
    
    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[ADER_34]

Korhan bey tam istediğim gibi kodlar sorunsuz işlem tamam,çok çok teşekkür ederim.Bu kodalrıda
arşive ekliyorum neredeyse yarım saatlik bir işlem 1 saniyede tamam,makrolarla çalışmak gerçekten çok güzel,kolay gelsin hayırlı geceler..