AccessTr.neT

Tam Versiyon: Makro İle Çoklu Satır Taşıma
Şu anda arşiv modunu görüntülemektesiniz. Tam versiyonu görüntülemek için buraya tıklayınız.
Sayfalar: 1 2
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?
Örnek dosya ve ne istediğim bu adreste. İlgilenirseniz çok sevinirim.

http://s3.dosya.tc/server10/i7wpwl/n_sek...7.rar.html
Sayfalar: 1 2