Makro koşullu veri taşıma

[erkandeveci]

Benim yapmak istediğim yukarıdaki listede f kolununa göre (segmente göre ) verileri diğer sayfalara aktarmak istiyorum ancak tüm verileri almak istemiyorum alacağım sütünlar şöyle olacak (A-B-C-D-E-F-Y-BE-BF-BH-BL)Sütunlarını alıp BF sütununa göre sıralama yapıp çalışma sayfalarına makro atayarak atmak isitiyorum bunu nasıl yapabilirim? Şimdiden çok teşekkür ederim...

 

[prmts]

Selam, aktarım yapacagınız kriter a1 hücresinde yazıyorsa; 1 adlı sayfaya aktarım yapıyorsunuz diyelim.

Sub aktar()
For i = 1 To Range("a65536").End(xlUp).Row
If Range("a1").Value = Range("f" & i).Value Then
d = Sheets("1").Range("a65536").End(xlUp).Row + 1
For t = 1 To 15
h = h + 1
If h = 7 Then h = 25
If h = 26 Then h = 57
If h = 60 Then h = 64
Sheets("1").Cells(d, t).Value = Cells(i, h).Value
Next t
h = 0
End If
Next i
Sheets("1").Select
Columns("A:O").Select
    ActiveWorkbook.Worksheets("1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("1").Sort.SortFields.Add Key:=Range("I2:I100"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("1").Sort
        .SetRange Range("A1:O8")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Kodları denermisiniz.

 

[erkandeveci]

Selam arama yapacağım kriter f sütündaki segmente göre olacak ama sırlama BFsütundaki rakamlara göre aynı zaman da sıralama yapacak..

 

[prmts]

Kriter f sütununda ok comboboxtamı yazılı makro neye göre sorgu yapacak. Üstteki kodları a1 hücresine örneğin "TİCARİ" yazarak birde nereye aktarım yapacak 1 adında bir sayfa oluşturun deneyin. Sıralama aktarım sonrası yapılacak.

 

[erkandeveci]

çok yordum sizi ; önceliklee teşekkür ederim
öncelikle satır başlıklar ını da beraberinde atmasını ve sadece F sütunundaki kriterelere göre kobi Mikro Ticari olarak çalışma sayfası atayabilirmi akabinde sıralama otomatik gelirse çok güzel olur...

 

[Korhan Ayhan]

Merhaba,

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.

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 <> "AAAAA" Then Sayfa.Delete
    Next
 
    Application.DisplayAlerts = True
 
10  Application.ScreenUpdating = False
 
    Set S1 = Sheets("AAAAA")
 
    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

 

[erkandeveci]

Çok teşekkür ederim çok işime yaradı...