Bir sütundaki değere göre süzdürmek ve başka dosyalara veri aktarımı

[cdata]

merhaba herkese

elimde bir excel dosyası var ve dosya 5 sütunda yer alan verilerden oluşuyor. amacım 4. sütundaki datanın pozitif değere sahip olduğu satırları, o satırın a sütunu ile aynı metin değerine sahip başka bir excel dosyasına yazdırmak.

örneklemek gerekirse a b c d e sütunlarından d sütununa bakıp d sütunundaki değer pozitifse a sütununa gidecek a sütunundaki metni alacak, eğer yoksa aynı isimde bir dosya açıp (LE400tr-b gibi) satırı aynen kopyalayacak, eğer böyle bir dosya varsa ilk boş satıra kaynak satırı aynen kopyalayacak bir programcık, script veya makro nasıl dizayn edilir? veya hazır (sadece ufak değiştirmeler yaparak kullanabileceğim) bir template var mıdır?

şimdiden teşekkür ederim.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub BİLGİLERİ_DOSYALARA_AKTAR()
    Dim K1 As Workbook, K2 As Workbook
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Dosya_Yolu As String, X As Long
 
    Application.ScreenUpdating = False
 
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sayfa1")
 
    Dosya_Yolu = K1.Path & "\"
 
    For X = 2 To S1.Range("A65536").End(3).Row
        If IsNumeric(S1.Cells(X, "D")) And S1.Cells(X, "D") > 0 Then
            If Dir(Dosya_Yolu & S1.Cells(X, "A") & ".xls") <> "" Then
                Set K2 = Workbooks.Open(Dosya_Yolu & S1.Cells(X, "A") & ".xls", False, False)
                Set S2 = K2.Sheets("Sayfa1")
                S1.Range("A" & X & ":E" & X).Copy S2.Range("A65536").End(3).Offset(1, 0)
                K2.Close True
            Else
                Set K2 = Workbooks.Add(1)
                Set S2 = K2.Sheets("Sayfa1")
                S1.Range("A1:E1").Copy S2.Range("A1")
                S1.Range("A" & X & ":E" & X).Copy S2.Range("A65536").End(3).Offset(1, 0)
                K2.SaveAs Filename:=Dosya_Yolu & S1.Cells(X, "A") & ".xls", FileFormat:=xlNormal
                K2.Close
            End If
        End If
    Next
 
    Set K1 = Nothing
    Set S1 = Nothing
    Set K2 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[cdata]

Çok teşekkür ederim. kod bir kaç ufak ayarlamadan sonra kusursuz çalışıp tam istediğim şeyi yaptı.