Makro ile veri getirme

[TİKOS]

Sayın arkadaşlar,
ekteki dosyada sorunumu paylaştım.Biraz uzun olduğu için buraya yazmadım.
yardımlarınızı rica ediyorum.

Saygılar,

 

[tahsinanarat]

Sayfa1 de yaptığımı geliştirebilirsiniz

Sn. Evren Gizlen Beyin yazdığı kodları Sayfa1 de uyarladım, siz kendinize göre geliştirebilirsiniz.
Dosyanız ekte

 

[TİKOS]

çok teşekkürler
ellerinize sağlık

 

[TİKOS]

tarihleride görmem gerekiyor
onu ne şekilde yapabiliriz.
yardımcı olursunuz sevinirim.
Sayfa1 A kolonunda

 

[askm]

Kodları şu şekilde revize edin.

Sub aktar()
Dim k As Range, sat As Long, i As Long, sh As Worksheet
Sheets("Sayfa1").Select
Range("b2:J65536").ClearContents
Application.ScreenUpdating = False
sat = Cells(65536, "B").End(xlUp).Row + 1
For Each sh In Worksheets
    'If Not IsNumeric(sh.Name) Then 'Sayfa isimleri 1,2,3,4,5 şeklinde olması halinde
        Set k = sh.[B8:B65536].Find([A1], LookAt:=xlPart)
        If Not k Is Nothing Then
            If sat >= 65533 Then
                MsgBox "Satır doldu.Kayıtların tamamı aktarılmadı!", vbCritical, "UYARI"
                Exit Sub
            End If
            Range("j" & sat).Value = sh.Range("B1").Value
            Range("B" & sat & ":I" & sat).Value = sh.Range("B" & k.Row & ":I" & k.Row).Value
            
            sat = sat + 1
        End If
    
Next
Application.ScreenUpdating = True
MsgBox "Aktarma Başarı ile tamamlandı." & vbLf & _
vbLf & "evrengizlen@hotmaial.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[TİKOS]

teşekkürler
örneğin ,1 dediğim shette Genel Gider de 2 adet 50 tl var
onun bir tanesini getiriyor. diğer günlerde de var.
kusura bakmayın uğraştırıyorum ama işime yaramadı bu hali ile

 

[askm]

Sub ozet()
    x = Worksheets.Count
    Set rapor = Worksheets("Sayfa1")
    ostr = 2
    sonsatir = Sayfa1.Cells(65536, "A").End(xlUp).Row
    For syf = 5 To x
        Sheets(syf).Select
        For satr = 8 To sonsatir
            If Sheets(syf).Cells(satr, 2).Value = Worksheets("Sayfa1").Range("A1").Value Then
                rapor.Cells(ostr, 2) = Sheets(syf).Cells(satr, 2)
                rapor.Cells(ostr, 4) = Sheets(syf).Cells(satr, 4)
                rapor.Cells(ostr, 6) = Sheets(syf).Cells(satr, 6)
                rapor.Cells(ostr, 9) = Sheets(syf).Cells(satr, 9)
                rapor.Cells(ostr, 10) = CDate(Sheets(syf).Cells(1, 2).Value) ', "gg.aa.yyyy")
                
                ostr = ostr + 1
            End If
        Next
                ostr = ostr + 1
    Next
    rapor.Select

End Sub

 

[tahsinanarat]

Farklı bir çalışma

İstenmeyen satırların kodlarını silebilirsiniz

Public Sub ara1()
ARANAN = Worksheets("Ekstre").Cells(2, 5)
Range("A11:Z65536").ClearContents
Worksheets("Ekstre").Cells(2, 5).Activate
If ARANAN = "" Then
Worksheets("Ekstre").Cells(1, 2).Value = ""
Worksheets("Ekstre").Cells(2, 5).Activate
Range("H9").Value = Time
Range("E9").Value = Date
Exit Sub
End If

sayfalar = Array("1", "2", "3", "4", "5", "6")
SAY = 0

For i = 0 To 2
With Worksheets(sayfalar(i)).Range("b8:b62500")
Set c = .Find(ARANAN, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
Worksheets("Ekstre").Cells(1, 2).Value = "ARANIYOR"
Range("H9").Value = Time
Range("E9").Value = Date

Do

Adres = c.Address
Adres = Right(Adres, Len(Adres) - 1)
ky = InStr(1, Adres, "$", 1)
AD1 = Right(Adres, Len(Adres) - ky)
Worksheets("Ekstre").Cells(11 + SAY, 1).Value = SAY + 1
Worksheets("Ekstre").Cells(11 + SAY, 1).Value = sayfalar(i)
Worksheets("Ekstre").Cells(11 + SAY, 2).Value = c
Worksheets("Ekstre").Cells(11 + SAY, 3).Value = Trim(Worksheets(sayfalar(i)).Cells(AD1, 4).Value)
Worksheets("Ekstre").Cells(11 + SAY, 4).Value = Trim(Worksheets(sayfalar(i)).Cells(AD1, 6).Value)
Worksheets("Ekstre").Cells(11 + SAY, 5).Value = Trim(Worksheets(sayfalar(i)).Cells(AD1, 8).Value)
Worksheets("Ekstre").Cells(11 + SAY, 6).Value = Trim(Worksheets(sayfalar(i)).Cells(AD1, 9).Value)
Worksheets("Ekstre").Cells(11 + SAY, 7).Value = Trim(Worksheets(sayfalar(i)).Cells(AD1, 10).Value)
Worksheets("Ekstre").Cells(11 + SAY, 8).Value = Trim(Worksheets(sayfalar(i)).Cells(AD1, 12).Value)
Worksheets("Ekstre").Cells(11 + SAY, 9).Value = Trim(Worksheets(sayfalar(i)).Cells(AD1, 14).Value)
Worksheets("Ekstre").Cells(11 + SAY, 10).Value = Trim(Worksheets(sayfalar(i)).Cells(AD1, 16).Value)
Worksheets("Ekstre").Cells(11 + SAY, 11).Value = Trim(Worksheets(sayfalar(i)).Cells(AD1, 18).Value)
Worksheets("Ekstre").Cells(11 + SAY, 12).Value = Trim(Worksheets(sayfalar(i)).Cells(AD1, 20).Value)
Worksheets("Ekstre").Cells(11 + SAY, 13).Value = Trim(Worksheets(sayfalar(i)).Cells(AD1, 22).Value)
Worksheets("Ekstre").Cells(11 + SAY, 14).Value = Trim(Worksheets(sayfalar(i)).Cells(AD1, 24).Value)
Worksheets("Ekstre").Cells(11 + SAY, 15).Value = Trim(Worksheets(sayfalar(i)).Cells(AD1, 26).Value)
Worksheets("Ekstre").Cells(11 + SAY, 16).Value = Trim(Worksheets(sayfalar(i)).Cells(AD1, 28).Value)
Worksheets("Ekstre").Cells(11 + SAY, 17).Value = Trim(Worksheets(sayfalar(i)).Cells(AD1, 30).Value)
Worksheets("Ekstre").Cells(11 + SAY, 18).Value = Trim(Worksheets(sayfalar(i)).Cells(AD1, 32).Value)
Worksheets("Ekstre").Cells(11 + SAY, 19).Value = Trim(Worksheets(sayfalar(i)).Cells(AD1, 33).Value)
Set c = .FindNext(c)
SAY = SAY + 1
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Worksheets("Ekstre").Cells(1, 8).Value = SAY
End With
Next
ActiveSheet.Calculate
Range("e2").Select
End Sub

dosyanız ekte

 

[tahsinanarat]

Sn. askm 7.mesajınızdaki kodlardan sonuç alamadım, deneyebilirmisiniz.

 

[askm]

Ekteki dosyayı