Merhabalar,
Girilen tarihe göre (Özet Tablo!A2 ) diğer çalışma sayfasından ( Data ) aynı tarihi içeren satırları Özet tablo sayfasına aldırmak istiyorum. Alınacak sütunlar ( B-C-D-E-F-G-H-I-J-K-L ) sütunlarıdır. diğer sütunların taşınmasına gerek yoktur. Bu taşıma işlemini makro veya başka formüller yazarak almak istiyorum. Yardımcı olacak arkadaşlara şimdiden teşekkür ederim..
Örneğinizi inceleme fırsatım olmadı. Ancak macro kaydet yöntemiyle yapmayı denediniz mi?
Saygılar...
Sorunuz tam anlaşılmıyor ney nereye taşınacak anlamadım.
Yinede şöyle bir örnek verebilim kendinize göre uyarlayınız.
Aşağıdaki kodu boş bir modüle uygulayıp deneyiniz.
Kod çalışırken ilk olarak size daha önce aktarım yaptığınız sayfaları silmek istiyormusunuz diye soracak evet derseniz önceki aktarım yapılan sayfalar silinecek. Hayır derseniz varolan sayfaların alt satırlarına devam ederek aktarım yapacaktır.
Kod:
Option Explicit
Sub AKTAR()
Dim S1, S2, S3, Sayfa, X, Satir
If MsgBox("Daha önce aktardığınız sayfaları silmek istiyor musunuz?", vbCritical + vbYesNo) = vbNo Then GoTo 10
Application.DisplayAlerts = False
For Each Sayfa In ThisWorkbook.Worksheets
If Sayfa.Name <> "Data" Then Sayfa.Delete
Next
Application.DisplayAlerts = True
10 Application.ScreenUpdating = False
Set S1 = Sheets("Data")
S1.Range("F1:F" & Rows.Count).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S1.Cells(1, Columns.Count), Unique:=True
For X = 2 To S1.Cells(Rows.Count, Columns.Count).End(3).Row
S1.Range("A1").AutoFilter Field:=6, Criteria1:=S1.Cells(X, Columns.Count)
If Sayfa_Kontrol(S1.Cells(X, Columns.Count)) Then
Set S2 = Sheets(S1.Cells(X, Columns.Count).Text)
Satir = S2.Cells(Rows.Count, 1).End(3).Row + 1
If S1.Cells(Rows.Count, 1).End(3).Row > 1 Then
S1.Range("A2:F" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S2.Cells(Satir, 1)
S1.Range("Y2:Y" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S2.Cells(Satir, 7)
S1.Range("BE2:BF" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S2.Cells(Satir, 8)
S1.Range("BH2:BH" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S2.Cells(Satir, 10)
S1.Range("BL2:BL" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S2.Cells(Satir, 11)
S2.Range("A2:K" & Rows.Count).Sort Key1:=S2.Range("I2"), Order1:=xlAscending
End If
Else
Set S3 = Sheets.Add
S3.Move After:=Worksheets(Worksheets.Count)
S3.Name = S1.Cells(X, Columns.Count)
S1.Range("A1:F" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S3.Cells(1, 1)
S1.Range("Y1:Y" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S3.Cells(1, 7)
S1.Range("BE1:BF" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S3.Cells(1, 8)
S1.Range("BH1:BH" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S3.Cells(1, 10)
S1.Range("BL1:BL" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S3.Cells(1, 11)
S3.Range("A2:K" & Rows.Count).Sort Key1:=S3.Range("I2"), Order1:=xlAscending
End If
Next
S1.Select
S1.Cells(1, Columns.Count).EntireColumn.Delete
S1.Range("A1").AutoFilter Field:=6
Set S1 = Nothing
Set S2 = Nothing
Set S3 = Nothing
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Function Sayfa_Kontrol(Sayfa_Adi As String) As Boolean
On Error Resume Next
Sayfa_Kontrol = CBool(Len(Worksheets(Sayfa_Adi).Name > 0))
End Function
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [G:G]) Is Nothing Then GoTo 10
On Error GoTo son
ActiveSheet.Unprotect
Cells.Locked = False
If Target.Value = "MASRAF" Then
Range("I:I").Locked = True
ActiveSheet.Protect
End If
If Target.Value = "ÇIKAN" Then
Range("I:I,H:H").Locked = True
ActiveSheet.Protect
End If
If Target.Value = "SATIŞ" Then
Range("I:I,H:H").Locked = True
ActiveSheet.Protect
End If
If Target.Value = "ALC DEKONT" Then
Range("I:I,H:H").Locked = True
ActiveSheet.Protect
End If
If Target.Value = "GİREN" Then
Range("J:J,H:H").Locked = True
ActiveSheet.Protect
End If
If Target.Value = "ALIŞ" Then
Range("J:J,H:H").Locked = True
ActiveSheet.Protect
End If
If Target.Value = "BRÇ DEKONT" Then
Range("J:J,H:H").Locked = True
ActiveSheet.Protect
End If
If Target.Value = "KASA DEVRİ" Then
Range("J:J,H:H").Locked = True
ActiveSheet.Protect
son:
End If
10:
If Intersect(Target, [F:F]) Is Nothing Then GoTo 20
If Target <> "" And Target = Cells(Target.Row, "M") Then
Cells(Target.Row, "G") = "ÇIKAN"
End If
20:
If Intersect(Target, [M:M]) Is Nothing Then GoTo 30
If Target <> "" And Target = Cells(Target.Row, "F") Then
Cells(Target.Row, "G") = "ÇIKAN"
End If
30:
For i = 1 To Sheets("KASA").Range("F5000").End(3).Row
If (Cells(i, "F") = "") Then GoTo atla
s = s + 1
For t = 1 To 13
If (Cells(t, "A") = "") Then GoTo atla
Sheets("RAPOR_2").Cells(s, t).Value = Sheets("KASA").Cells(i, t).Value
Next t
atla:
Next i
End Sub
Yukardaki makroyu, excel'i kasmadan çalışacak hale getirebilirmiyiz?