Yalnız Mesajı Göster
Eski 03-01-2018, 20:45  
sinan05
 
Giriş: 16/11/2017
Şehir: istanbul
Mesaj: 76
Excel Vers. ve Dili:
Excel 2016 Türkçe
Varsayılan

Hocalarım hallettim teşekkürler. Aşağıdaki kodları ekledim oldu. belki ihtiyacı olan olur diye tamamını ekliyorum herkese hayırlı akşamlar.
Sub Bakiyeler()
Application.ScreenUpdating = False
Dim tarih1 As Date, tarih2 As Date, xtarih As Date
Dim evn As Object, klasoradi As String, kitap As Workbook
Dim i As Integer, x As Integer, dosyam As Workbook
Set kitap = ThisWorkbook
kitap.Sheets("BAKİYELER").Range("a2:J65536").Clear Contents
tarih1 = kitap.Sheets("Sayfa1").Range("m1").Value
klasoradi = "Müşteriler"
Set evn = CreateObject("scripting.filesystemobject")
Set dosyalar = evn.getfolder(ThisWorkbook.Path & Application.PathSeparator & klasoradi)
For Each klasor In dosyalar.Files
Set dosyam = GetObject(klasor.Path)
For i = 1 To dosyam.Sheets.Count
For x = 24 To 24
If dosyam.Sheets(i).Cells(x, "g").Value <> "" Then
xtarih = dosyam.Sheets(i).Cells(x, "g").Value
If xtarih < tarih1 Then
dosyam.Sheets(i).Range("g" & x & "" & x).Copy
kitap.Sheets("BAKİYELER").Range("a65536").End(3)(2 , 1).PasteSpecial xlPasteValues
End If
End If
Next x
Next i
dosyam.Close False
Next klasor
ActiveWindow.SmallScroll Down:=-6
Range("B2:K501").Select
ActiveWindow.ScrollRow = 478
ActiveWindow.ScrollRow = 467
ActiveWindow.ScrollRow = 445
ActiveWindow.ScrollRow = 370
ActiveWindow.ScrollRow = 271
ActiveWindow.ScrollRow = 191
ActiveWindow.ScrollRow = 175
ActiveWindow.ScrollRow = 124
ActiveWindow.ScrollRow = 68
ActiveWindow.ScrollRow = 40
ActiveWindow.ScrollRow = 18
ActiveWindow.ScrollRow = 8
ActiveWindow.ScrollRow = 5
ActiveWindow.ScrollRow = 3
ActiveWindow.ScrollRow = 1
ActiveWorkbook.Worksheets("BAKİYELER").Sort.SortFi elds.Clear
ActiveWorkbook.Worksheets("BAKİYELER").Sort.SortFi elds.Add Key:=Range("B2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("BAKİYELER").Sort
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
End With
Range("M5").Select
Set evn = Nothing: Set kitap = Nothing: Set dosyam = Nothing
Application.ScreenUpdating = True
End Sub
sinan05 Çevrimdışı   Alıntı Yaparak Cevapla