bulentkars
Altın Üye
- Katılım
- 5 Ağustos 2005
- Mesajlar
- 671
- Excel Vers. ve Dili
- 2003 TR
- Altın Üyelik Bitiş Tarihi
- 23-03-2027
Arkadaşlar Merhaba,
Aşağıdaki kodu sorunsuz çalıştırıyorum. Ancak daha önce çalıştırdığım dosya sanırım askıda kalmış klasör altında dosya olmamasına rağmen eski dosyaların verileri geliyor, makroda değişkenlerin temzilenmesi için makroya ilave edilmesi kod konusunda yardımcı olabilirseniz sevinirim. Şimdiden Teşekkürler
Sub Rısk_Dosya_Birlestir()
Dim yol As String, Dosya As String, Sayfa(), sat As Long, i As Byte, a As Long, son As Long, S1 As Worksheet
ThisWorkbook.Activate
Set S1 = Sheets("Tüm Şubeler")
yol = "C:\Dosyalar\"
Dosya = Dir(yol & "\*.xls*")
Sayfa = Array("Log")
Application.ScreenUpdating = False
S1.Range("A2:K" & Rows.Count).ClearContents
sat = S1.Cells(Rows.Count, "I").End(xlUp).Row + 1
Do While Dosya <> ""
Workbooks.Open yol & Dosya
For i = 0 To UBound(Sayfa)
With Sheets(Sayfa(i))
Say = i
If S1.Range("A1") = "" Then
.Range("A1:K1").Copy S1.Range("A1")
End If
son = .Cells(Rows.Count, "I").End(xlUp).Row
If son > 1 Then
.Range("A1:K" & son).AutoFilter Field:=5, Criteria1:="<>"
.Range("A2:K" & son).SpecialCells(xlCellTypeVisible).Copy S1.Cells(sat, "A")
a = sat
sat = S1.Cells(Rows.Count, "I").End(xlUp).Row + 1
End If
End With
Next i
Workbooks(Dosya).Close False
Dosya = Dir
Loop
MsgBox "Dosyalar Başarıyla Birleştirildi..", vbInformation, Application.UserName
End Sub
Aşağıdaki kodu sorunsuz çalıştırıyorum. Ancak daha önce çalıştırdığım dosya sanırım askıda kalmış klasör altında dosya olmamasına rağmen eski dosyaların verileri geliyor, makroda değişkenlerin temzilenmesi için makroya ilave edilmesi kod konusunda yardımcı olabilirseniz sevinirim. Şimdiden Teşekkürler
Sub Rısk_Dosya_Birlestir()
Dim yol As String, Dosya As String, Sayfa(), sat As Long, i As Byte, a As Long, son As Long, S1 As Worksheet
ThisWorkbook.Activate
Set S1 = Sheets("Tüm Şubeler")
yol = "C:\Dosyalar\"
Dosya = Dir(yol & "\*.xls*")
Sayfa = Array("Log")
Application.ScreenUpdating = False
S1.Range("A2:K" & Rows.Count).ClearContents
sat = S1.Cells(Rows.Count, "I").End(xlUp).Row + 1
Do While Dosya <> ""
Workbooks.Open yol & Dosya
For i = 0 To UBound(Sayfa)
With Sheets(Sayfa(i))
Say = i
If S1.Range("A1") = "" Then
.Range("A1:K1").Copy S1.Range("A1")
End If
son = .Cells(Rows.Count, "I").End(xlUp).Row
If son > 1 Then
.Range("A1:K" & son).AutoFilter Field:=5, Criteria1:="<>"
.Range("A2:K" & son).SpecialCells(xlCellTypeVisible).Copy S1.Cells(sat, "A")
a = sat
sat = S1.Cells(Rows.Count, "I").End(xlUp).Row + 1
End If
End With
Next i
Workbooks(Dosya).Close False
Dosya = Dir
Loop
MsgBox "Dosyalar Başarıyla Birleştirildi..", vbInformation, Application.UserName
End Sub