sıra numarasına göre kopyalama

[muhasebeciyiz]

Sevgili arkadaşlar ekte sunmuş olduğum dosyam içindeki sıra numarası verdiğim sutunları başka sayfaya kopyalamak için yardımınıza ihtiyacım vardır.
Yardımcı olursanız çok sevinirim.Selamlar,

 

[Ömer BARAN]

Merhaba.
Aşağıdaki kodu kullanabilirsiniz.

Sub SIRALI_SUTUN_KOPYALA()
Set f = Sheets("Form")
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Sheets.Add , ActiveSheet
With ActiveSheet
    For sut = 1 To WorksheetFunction.Max(f.[1:1])
        Set fsut = f.[1:1].Find(sut)
        If Not fsut Is Nothing Then
            ysut = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
            If sut = 1 Then ysut = 1
            f.Range(f.Cells(1, fsut.Column), f.Cells(18, fsut.Column)).Copy
            .Cells(1, ysut).PasteSpecial Paste:=xlPasteValues
            .Cells(1, ysut).PasteSpecial Paste:=xlPasteFormats
            .Cells(1, ysut).ColumnWidth = f.Cells(1, fsut.Column).ColumnWidth
        End If
    Next
.[A1].Activate
End With
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "Gerekli kopyalama tamamlandı.", vbInformation, "..:: Ömer BARAN ::.."
End Sub

 

[muhasebeciyiz]

Elinize sağlık Ömer bey ; Teşekkür ediyorum.

 

[Ömer BARAN]

Eyvallah.
Meslek mensubuna destek vermek lazım.