üç ayrı sayfadan isme göre rapor alma makrosu

[osmanucel]

arkadaşlar üç ayrı sayfadan süzerek isme göre rapor almak ısdıyorum yardımcı olabılırmısınız

 

[Ömer]

Merhaba,

Sorunuzu küçük bir örnek dosya ekleyerek detaylı açıklarmısınız.

 

[osmanucel]

Dosya ekledim

Dosya bu ılk üç dosyadan

 

[osmanucel]

Yanlış dosya

Dosyayı yanlış yüklemişim özür dilerim

 

[osmanucel]

Alış satış ve kasa bu üç dosyadan isme göre rapor almak
istiyorum yardımcı olursanız sevınırım

 

[osmanucel]

Yokmu yardımcı olacak bırılerı

 

[Ömer]

Alış satış ve kasa bu üç dosyadan isme göre rapor almak
istiyorum yardımcı olursanız sevınırım

Aranan ismi Rapor sayfası A1 hücresine basıp kodu çalıştırın. A1 hücresindeki değeri sayfalardaki F sütununda arar bulduklarını listeler.

Sub Raporla()
 
    Dim c As Range, sat As Long, Adr As Variant, i As Integer
 
    Application.ScreenUpdating = False
 
    Sheets("RAPOR").Select
    Rows("2:" & Rows.Count).Clear
 
    Sheets("KASA").Range("B4:N5").Copy Range("A2")
 
    sat = 4
    For i = 1 To Worksheets.Count
        With Sheets(i)
            If .Name <> "RAPOR" Then
                Set c = .[[COLOR=blue]F:F[/COLOR]].Find(Range("[COLOR=red]A1[/COLOR]"), , xlValues, xlWhole)
                If Not c Is Nothing Then
                  Adr = c.Address
                    Do
                      .Range("B" & c.Row, "N" & c.Row).Copy Range("A" & sat)
                      sat = sat + 1
                      Set c = .[[COLOR=blue]F:F[/COLOR]].FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> Adr
                End If
            End If
        End With
    Next i
 
    Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True
 
 End Sub

.

 

[osmanucel]

hocam yapamadım sanırım dosyaya sız ekleyıp gönderebılırmısınız

 

[Orion1]

Dosyanız ektedir.

Private Sub CommandButton1_Click()
Dim sat As Long, sh As Worksheet, sf()
Sheets("RAPOR").Select
Range("B5:N" & Rows.Count).Clear
Application.ScreenUpdating = False
sf = Array("", "ALIŞ", "SATIŞ", "KASA")
For i = 1 To 3
    Set sh = Sheets(sf(i))
    sh.Range("B4").AutoFilter
    sh.Range("B4").AutoFilter field:=5, Criteria1:=TextBox1.Text & "*"
    If WorksheetFunction.Subtotal(103, sh.Range("B5:B" & sh.Rows.Count)) > 0 Then
        sat = Cells(Rows.Count, "B").End(xlUp).Row + 1
        sh.Range("B4").CurrentRegion.Offset(1, 0).Copy
        Range("B" & sat).PasteSpecial (xlPasteValuesAndNumberFormats)
    End If
    Application.CutCopyMode = False
    sh.Range("B4").AutoFilter
    Set sh = Nothing
Next i
Application.ScreenUpdating = True
Unload Me
MsgBox "İşlem tamamlanmıştır." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation
End Sub

 

[osmanucel]

Hocam cok sagolun super oldu

 

[osmanucel]

Hocam cok sahane olduda bı sorun daha var
gelen bılgıler tarıh sırasına göre otomatık yapabılırmıyız

 

[osmanucel]

bı el daha atabılırmıyız lutfen

 

[osmanucel]

Private Sub CommandButton7_Click()

Dim sat As Long, sh As Worksheet, sf()
Sheets("RAPOR").Select

Range("B5:N" & Rows.Count).Clear
Application.ScreenUpdating = False
sf = Array("", "ALIŞ", "SATIŞ", "KASA")
For i = 1 To 3
Set sh = Sheets(sf(i))
sh.Range("B5").AutoFilter
sh.Range("B4").AutoFilter field:=5, Criteria1:=ComboBox44.Text & "*"
If WorksheetFunction.Subtotal(103, sh.Range("B4:B" & sh.Rows.Count)) > 0 Then
sat = Cells(Rows.Count, "B").End(xlUp).Row + 1
sh.Range("B5").CurrentRegion.Offset(1, 0).Copy
Range("B" & sat).PasteSpecial (xlPasteValuesAndNumberFormats)
End If
Application.CutCopyMode = False
sh.Range("B4").AutoFilter
Set sh = Nothing
Next i
Application.ScreenUpdating = True
Unload Me
MsgBox "İşlem tamamlanmıştır." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation
End Sub

 

[osmanucel]

sh.Range("B4").AutoFilter field:=5, Criteria1:=ComboBox44.Text & "*"

 

[osmanucel]

sh.Range("B4").AutoFilter field:=5, Criteria1:=ComboBox44.Text & "*"

kodun burda bı hata verıyo

 

[osmanucel]

lutfen bı yardımcı olurmusunuz

 

[Ömer]

Bu kadar aceleci olmayın lütfen. Sayın Orion1 şuan forumda değil gelince isteğiniz doğrultusunda kodu revize edecektir.

Benim yazdığım kodun dosyaya uygulanmış hali ektedir. Sıralama ölçütü ilaveside eklenmiştir.

.

 

[osmanucel]

özur dılerım tesekkur ederım ılgınıze

 

[osmanucel]

Aömer bey bu sekıldede cok guzel tesekkurler
cok sagolun

 

[orange4609]

içerir olarak yapılabilir mi?

slm
içerir olarak yapabilirmiyiz.yani;g sutununda ö içeriyorsa tüm ö içeren bilgileri aktarsın gibi.

iyi çalışmalar.