Makro ilave Yardım..

[bulentkars]

Arkadaşlar Merhaba

Aşağıdaki makroyu çalıştırdığımda C:\MUTABAKAT\ Klasörünün altındaki Xls dosyalarını tek tek açıp alt alta kopyalalıyorum.Buna ilave olarak Örneğin Deneme.XLS dosyasını açıp A1:A Arasını kopyalayıp A Sutununa yapıştıtıyorum B sutununa da aşağıya doğru dosya adlarınıda yazdırabilrimiyim.Yani B sutununa Deneme aşağıya doğru Sonunda uzantısı xls olmayacak şeklilde.Tabi dosya isimleri her açılan sayfa için olacak.

Sub Kıtap_Kopyala()



Dim say As Long
Dim say2 As Long
Dim Dosya As String

Dosya = Dir("C:\MUTABAKAT\*.XLS") ' klasör yerı belırlenır.

Do Until Dosya = ""
Workbooks.Open "C:\MUTABAKAT\" & Dosya ' klasör yeri belirlenir
say = WorksheetFunction.CountA(Range("A:A"))
say2 = WorksheetFunction.CountA(ThisWorkbook.Worksheets("Extre").Range("A:A")) + 1 Range("A2:A" & say).Copy ThisWorkbook.Worksheets("Extre").Range("A" & say2) ' kopyalacak aralık belırlenır

Dosya = Dir
ActiveWorkbook.Close False
Loop
End Sub