Excel Forum

Excel Forum (http://www.excel.web.tr/index.php)
-   Makro-VBA (http://www.excel.web.tr/forumdisplay.php?f=48)
-   -   Koşula göre başka sayfadan veriler getirme (http://www.excel.web.tr/showthread.php?t=169480)

sinan05 03-01-2018 20:13

Koşula göre başka sayfadan veriler getirme
 
Hocalarım merhabalar, herkese hayırlı akşamlar. Bir konuda daha yardımınıza ihtiyacım var. Makro tam oldu diyorum çalışmama göre başka hatalar çıkıyor. Sorunum şu aşağıda yazmış olduğum kodlar müşteriler klosörüne gidip ordaki çalışma kitablarındaki ve her sayfasındaki G24:P24 arasındaki verileri getiriyor. G24 hücresinde tarih var. Ben buraya bir koşul eklemek istiyorum. Eğer G24 hücresindeki tarih içinde bulunduğumuz aydan küçükse belirtilen vrileri getirsin. içinde bulunduğumuz bir aya ait ise getirmesin. Yardımlarınız için şimdiden teşekkür ederim.

Sub Bakiyeler()
Application.ScreenUpdating = False
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
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
dosyam.Sheets(i).Range("g" & x & "p" & x).Copy
kitap.Sheets("BAKİYELER").Range("a65536").End(3)(2 , 1).PasteSpecial xlPasteValues
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 03-01-2018 20:45

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 & ":p" & 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


Saat 16:22

Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.