Makro ile Veri Ayrıştırma

[scoskunsu07]

Merhaba,

Elimde bir numara listesi var ve çok sayıda sheetin olduğu bir çalışma kitabı var. ilk sayfadaki numaralara göre her sheetde bulunan sabit bir hücrede (D7) arama yapmasını ve eğer ilgili numara varsa o sheeti başka bir excele atmasını istiyorum. YAni sonuç olarak ilk sayfadaki numaraların olduğu bütün sheetler tek bir excelde elde etmek istiyorum. Örnek excel eklenmiştir.

İndir makro

Dosyayı indir makro

dosya.co

 

[veyselemre]

Sub test()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set wb = ActiveWorkbook
    With CreateObject("Scripting.Dictionary")
        For Each i In Sheets("Sayfa7").Range("A1", Sheets("Sayfa7").Cells(Rows.Count, 1).End(3))
            .Item(Trim(i)) = Null
        Next i
        For Each i In wb.Sheets
            If i.Name <> "Sayfa7" Then
                If .exists(Trim(i.Range("D7").Value)) Then
                    i.Copy
                    ActiveWorkbook.SaveAs wb.Path & "\" & Trim(i.Range("D7").Value)
                    ActiveWorkbook.Close
                End If
            End If
        Next i
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

 

[scoskunsu07]

Öncelikle vakit ayırdığınız için teşekkür ederim. Makroyu denedim ama ayırmadı. Evet arkaplanda çalışıyor ama ayırdıysa da başka bir excele kaydetmedi seçtiği sheetleri

 

[veyselemre]

Ben soruyu yanlış anlamışım. Önceki kod listedeki sheetleri ayrı ayrı çalışma kitabı olarak aktif dosyanın bulunduğu dizine kopya yapıyor.
Aşağıki kod listedeki sayfalar mevcutsa yeni bir çalışma kitabına yine aynı yere kayıt eder.

Sub test()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set wb = ActiveWorkbook
    With CreateObject("Scripting.Dictionary")
        For Each i In Sheets("Sayfa7").Range("A1", Sheets("Sayfa7").Cells(Rows.Count, 1).End(3))
            .Item(Trim(i)) = False
        Next i
        For Each i In wb.Sheets
            If i.Name <> "Sayfa7" Then
                If .exists(Trim(i.Range("D7").Value)) Then
                    .Item(i.Name) = True
                End If
            End If
        Next i
        kys = .keys
        itms = .items
        For i = 0 To UBound(kys)
            If Not itms(i) Then .Remove (kys(i))
        Next i
        kys = .keys
        If UBound(kys) > -1 Then
            Sheets(kys).Copy
            ActiveWorkbook.SaveAs wb.Path & "\seciliSayfalar.xlsx"
            ActiveWorkbook.Close
        End If
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

 

[scoskunsu07]

Şimdi istediğim gibi oldu. Çok teşekkür ederim

 

[scoskunsu07]

Ben soruyu yanlış anlamışım. Önceki kod listedeki sheetleri ayrı ayrı çalışma kitabı olarak aktif dosyanın bulunduğu dizine kopya yapıyor.
Aşağıki kod listedeki sayfalar mevcutsa yeni bir çalışma kitabına yine aynı yere kayıt eder.

Sub test()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set wb = ActiveWorkbook
    With CreateObject("Scripting.Dictionary")
        For Each i In Sheets("Sayfa7").Range("A1", Sheets("Sayfa7").Cells(Rows.Count, 1).End(3))
            .Item(Trim(i)) = False
        Next i
        For Each i In wb.Sheets
            If i.Name <> "Sayfa7" Then
                If .exists(Trim(i.Range("D7").Value)) Then
                    .Item(i.Name) = True
                End If
            End If
        Next i
        kys = .keys
        itms = .items
        For i = 0 To UBound(kys)
            If Not itms(i) Then .Remove (kys(i))
        Next i
        kys = .keys
        If UBound(kys) > -1 Then
            Sheets(kys).Copy
            ActiveWorkbook.SaveAs wb.Path & "\seciliSayfalar.xlsx"
            ActiveWorkbook.Close
        End If
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Merhaba, Bu kodda çalışırken " If .exists(Trim(i.Range("D7").Value)) Then " kısmında hata alıyorum sebebi ne olabilir acaba