üç sayfadan veri süzme

[kesikbey]

Arkadaşlar bir çalışma kitabının 3 sayfasındaki verilei süzüp, dördüncü sayfaya akatarması mümkünmü acaba... Gerekli açıklama dosya içeriğinde var....

 

[asi_kral]

Arkadaşlar bir çalışma kitabının 3 sayfasındaki verilei süzüp, dördüncü sayfaya akatarması mümkünmü acaba... Gerekli açıklama dosya içeriğinde var....

Merhaba
Userformda combobox1 ( isimbox'un ) row source olayının karşısını temizleyin ve userformun kod bölümüne bu kodu kopyalayın.

Private Sub CommandButton1_Click()
'Konu       :   Seçilen İsme Göre Aktar
'Mail       :   m.batu.1967@gmail.com
'Coder By   :   asi_kral_1967
Dim asi, kral
Dim a, b, c
Application.ScreenUpdating = False
Set kral = Sheets("Rapor")
kral.Range("B5:O" & Rows.Count).ClearContents
kral.Select
c = ActiveCell.Address
b = kral.Range("B" & Rows.Count).End(xlUp).Row + 1
Set asi = Sheets("msh")
a = asi.Range("B" & Rows.Count).End(xlUp).Row
asi.Range("B1:O" & a).AutoFilter field:=2, Criteria1:=isimbox.Value
If WorksheetFunction.Subtotal(3, asi.Range("B2:B" & a)) > 0 Then
asi.Range("B2:O" & a).Copy
kral.Range("B" & b).PasteSpecial (xlPasteValues)
End If
asi.Range("B2:O" & a).AutoFilter
b = kral.Range("B" & Rows.Count).End(xlUp).Row + 1
Set asi = Sheets("depo")
a = asi.Range("B" & Rows.Count).End(xlUp).Row
asi.Range("B1:O" & a).AutoFilter field:=2, Criteria1:=isimbox.Value
If WorksheetFunction.Subtotal(3, asi.Range("B2:B" & a)) > 0 Then
asi.Range("B2:O" & a).Copy
kral.Range("B" & b).PasteSpecial (xlPasteValues)
End If
asi.Range("B2:O" & a).AutoFilter
b = kral.Range("B" & Rows.Count).End(xlUp).Row + 1
Set asi = Sheets("AKTARILAN")
a = asi.Range("B" & Rows.Count).End(xlUp).Row
asi.Range("B1:O" & a).AutoFilter field:=2, Criteria1:=isimbox.Value
If WorksheetFunction.Subtotal(3, asi.Range("B2:B" & a)) > 0 Then
asi.Range("B2:O" & a).Copy
kral.Range("B" & b).PasteSpecial (xlPasteValues)
End If
asi.Range("B2:O" & a).AutoFilter
kral.Select
Range(c).Select
Application.ScreenUpdating = True
Unload Me
MsgBox isimbox & " İsimli Kişilerin Verilerini Aktardım", vbInformation, "asi_kral_1967"
End Sub
Private Sub UserForm_Initialize()
'Konu       :   Combobox'a Verileri Al
'Mail       :   m.batu.1967@gmail.com
'Coder By   :   asi_kral_1967
Dim asi, kral
Set kral = Sheets("veri")
For asi = 2 To kral.Cells(Rows.Count, "A").End(xlUp).Row
If WorksheetFunction.CountIf(kral.Range("A2:A" & asi), _
kral.Cells(asi, "A")) = 1 Then
isimbox.AddItem kral.Cells(asi, "A")
End If
Next
End Sub

Dosyanız ekte

 

[kesikbey]

Kral Kardeşim çok tşkrler. Tam istediğim gibi.

 

[asi_kral]

Kral Kardeşim çok tşkrler. Tam istediğim gibi.

Kolay Gelsin.