Sayfalar arası koşullu süzme ve aktarma işlemi

[ozmacig]

Merhaba Arkadaşlar...

Ekte sunduğum excell'de araç kartı bulunmaktadır. araçların plaka olarak sayfa yaptım ve bu sayfalardaki verileri aylık olarak (örneğin : ocak ayına ait) verileri VERİ sayfasındaki A sutunun daki plakalar baz alınarak, AKTAR sayfasına aktarmak istiyorum. bunu nasıl yapa bilirim yardımcı olursanız sevinirim.. saygılarımla

 

[asi_kral]

Merhaba
Ay bilgisini nerede bunu nereden bileceğiz._?

 

[ozmacig]

Merhaba hocam...

Exceli incelediğimizde plaka isimli kartlarım var .. plaka kartlarının üzerinde ocak , şubat, mart .... aralık aylarına ait dökümler bulunmaktadır. (örnek 34 BYZ 654;34 BYZ 655;34 KK 777 kartının ocak ayı B4 : M4 hücresine kadar kısmını veri sayfasındaki plakalar baz alınarak aktar sayfasına aktarma)

elimde örnek bir kot var yol göstermek amacıyla :

Sheets("AKTAR").Select
Range("A2:O65536").ClearContents
Dim i, J, Ay As Integer
J = 1
Ay = Application.InputBox("Hangi Ay Aktarılacak?", "O Z ", Default:=1, Type:=1)

If Ay = False Then Exit Sub
Ay = Ay + 6

For i = 45 To Sheets.Count
J = J + 1
Cells(J, "A") = Sheets(i).Name
Sheets(i).Range("B" & Ay & ":F" & Ay).Copy Cells(J, "B")
Next i

ancak bu kodda veri sayfasındaki plaka no su baz alınarak süz me ve aktarma yapmak istiyorum

 

[asi_kral]

Merhaba
Bu kodu dener misiniz_?

Option Explicit
Sub veri_çek()
Dim STR As Long, AY As String, STR1 As Long, STR3 As Long
Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
AY = Application.InputBox("Ay Girişi" & vbLf & _
"Ocak Şeklinde", "Ay Giriniz")
Application.ScreenUpdating = False
Set S1 = Sheets("veri")
Set S3 = Sheets("aktar")
S3.Range("A2:M" & Rows.Count).ClearContents
If AY <> Empty Then
With WorksheetFunction
STR1 = 2
For STR = 2 To S1.Cells(Rows.Count, "A").End(xlUp).Row
Set S2 = Sheets(S1.Cells(STR, "A").Text)
STR3 = WorksheetFunction.Match(AY, S2.Range("A:A"), 0)
S3.Cells(STR1, "A") = S1.Cells(STR, "A")
S2.Range("B" & STR3 & ":L" & STR3).Copy _
S3.Range("B" & STR1)
S3.Cells(STR1, "M") = S1.Cells(STR, "A") & " Plaka Nolu Araçın " & AY _
& " Ayı Dökümü"
STR1 = STR1 + 1
Next
End With: End If
S3.Range("A2:M" & Rows.Count).Interior.ColorIndex = xlNone
Application.ScreenUpdating = True
End Sub

 

[ozmacig]

Hocam ellerine sağlık . fakat aktar sayfasında ufak bir değişiklik yaptım. ekteki forma göre yeniden değişiklik yapabilirmiyiz. zahmet olmasa.

 

[asi_kral]

Hocam ellerine sağlık . fakat aktar sayfasında ufak bir değişiklik yaptım. ekteki forma göre yeniden değişiklik yapabilirmiyiz. zahmet olmasa.

Merhaba
Grup numarasını göremedim.

Option Explicit
Sub veri_çek()
Dim STR As Long, AY As String, STR1 As Long, STR3 As Long
Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
AY = Application.InputBox("Ay Girişi" & vbLf & _
"Ocak Şeklinde", "Ay Giriniz")
Application.ScreenUpdating = False
Set S1 = Sheets("veri")
Set S3 = Sheets("aktar")
S3.Range("A2:M" & Rows.Count).ClearContents
If AY <> Empty Then
STR1 = 2
For STR = 2 To S1.Cells(Rows.Count, "A").End(xlUp).Row
Set S2 = Sheets(S1.Cells(STR, "A").Text)
STR3 = WorksheetFunction.Match(AY, S2.Range("A:A"), 0)
S3.Cells(STR1, "A") = STR - 1
S3.Cells(STR1, "B") = "Burası Belli Değil"
S3.Cells(STR1, "C") = S2.Range("A2")
S3.Cells(STR1, "D") = S2.Cells(STR3, "B")
S3.Cells(STR1, "E") = S2.Cells(STR3, "C")
S3.Cells(STR1, "F") = S2.Cells(STR3, "D")
S3.Cells(STR1, "G") = S1.Cells(STR, "A") & " Plaka Nolu Araçın " & AY _
& " Ayı Dökümü"
STR1 = STR1 + 1
Next: End If
Application.ScreenUpdating = True
End Sub

 

[ozmacig]

hocam ellerin dert görmesin ....

 

[asi_kral]

hocam ellerin dert görmesin ....

Kolay Gelsin.