ft listesini sıralama

[NADİR YILDIZ]

Arkadaşlar ekteki dosyada anlattığım gibi üstte bir fatura listesi var.listede % 18 % 8 % 1 li satış faturaları listesi var.. benim istediğim yukardaki listedekileri aşağıdaki gibi fatura sırasına göre üst listede kaç tane varsa aşağıdaki listeye aktarmasını istiyorum

 

[NADİR YILDIZ]

bu konuda yardımcı olabilecek kimse yokmu acaba

 

[YUSUF44]

Aşağıdaki kodları bir modüle kopyalayıp deneyin:

Sub fatura()
For i = 2 To WorksheetFunction.Max([a1].End(xlDown).Row, Cells(Rows.Count, "i").End(3).Row, Cells(Rows.Count, "q").End(3).Row)
yeni = Cells(Rows.Count, 1).End(3).Row + 1

If Cells(i, "A") <> "" Then
    Cells(i, "A").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Cells(yeni, "A").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
        If Cells(i, "i") <> "" Then
            Cells(i, "i").Select
            Range(Selection, Selection.End(xlToRight)).Select
            Selection.Copy
            Cells(yeni + 1, "A").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
                If Cells(i, "q") <> "" Then
                    Cells(i, "q").Select
                    Range(Selection, Selection.End(xlToRight)).Select
                    Selection.Copy
                    Cells(yeni + 2, "A").Select
                    ActiveSheet.Paste
                    Application.CutCopyMode = False
                End If
        Else
        If Cells(i, "q") <> "" Then
            Cells(i, "q").Select
            Range(Selection, Selection.End(xlToRight)).Select
            Selection.Copy
            Cells(yeni + 1, "A").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
        End If
        End If
Else
If Cells(i, "i") <> "" Then
    Cells(i, "i").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Cells(yeni, "A").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
        If Cells(i, "q") <> "" Then
            Cells(i, "q").Select
            Range(Selection, Selection.End(xlToRight)).Select
            Selection.Copy
            Cells(yeni + 1, "A").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
        End If
Else
    Cells(i, "q").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Cells(yeni, "A").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
End If
End If
Next
[a1].Select
bitti = MsgBox("İşlem tamam!")
End Sub

 

[YUSUF44]

Aşağıdaki kod daha pratik ve güzel oldu:

Sub fatura()
  Set c = [a2:a65536].Find("TARİH")
If Not c Is Nothing Then son = c.Row-2

For i = 2 To WorksheetFunction.Max(c, Cells(Rows.Count, "i").End(3).Row, Cells(Rows.Count, "q").End(3).Row)

    Range(Cells(i, "a"), Cells(i, "g")).Select
    Selection.Copy
    Cells(Rows.Count, 1).End(3).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    Range(Cells(i, "i"), Cells(i, "o")).Select
    Selection.Copy
    Cells(Rows.Count, 1).End(3).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    Range(Cells(i, "q"), Cells(i, "w")).Select
    Selection.Copy
    Cells(Rows.Count, 1).End(3).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
                
Next
[a1].Select
bitti = MsgBox("İşlem tamam!")
End Sub