sütunları sayfalara kopyalamak

[jackal07]

merhaba belki sizin için çok basit bir şey ama ben bir türlü beceremiyorum ve bunu yapabilmek için bir iki saatimi veriyorum. sizden ricam gönderdiğim excel tablosunda bakarsanız orada olmasını istediğim şey tam olrak şöyle

A sütunu + B sütunu sayfa 2 ye
A sütunu + C sütunu sayfa 3 e
A sütunu + D sütunu sayfa 4 e
gibi ben bunların ger birini ayrı ayrı ayırıp
tek tek kopyala yapıştır yapıyorum bunu bir yolu varmı acaba

 

[fedeal]

Sub n()
For F = 2 To [COLOR="Red"]63[/COLOR]
    Sheets("Sayfa1").Copy After:=Sheets(F - 1)
    Sheets("Sayfa1 (" & F & ")").Range("B1:BL65000").ClearContents
For i = 1 To Sheets("Sayfa1").Range("A65536").End(xlUp).Row + 1
    Sheets("Sayfa1 (" & F & ")").Cells(i, 2).Value = Sheets("Sayfa1").Cells(i, F).Value
Next
Next
Sheets("Sayfa1").Select
End Sub

Dosyanız ekte,iyi çalışmalar.
not:kırmızı yazılan 63 sütun sayısı verileriniz daha fazla sütun olursa arttırın.

 

[hamitcan]

Alternatif;

Sub SutunlariAyriSayfalaraKopyala()
sil
c = 1
son = Cells.SpecialCells(xlLastCell).Column - 1
For i = 2 To son
    Sheets.Add , ActiveSheet
    ActiveSheet.Name = "Sayfa" & i
    c = c + 1
    ActiveSheet.[a:a] = Sheets("Sayfa1").[a:a].Value
    ActiveSheet.Columns(2) = Sheets("Sayfa1").Columns(c).Value
Next
End Sub
Sub sil()
Application.DisplayAlerts = False
    For i = Sheets.Count To 1 Step -1
     If Sheets(i).Name <> "Sayfa1" Then Sheets(i).Delete
    Next
Application.DisplayAlerts = True
End Sub

 

[jackal07]

Sub n()
For F = 2 To [COLOR="Red"]63[/COLOR]
    Sheets("Sayfa1").Copy After:=Sheets(F - 1)
    Sheets("Sayfa1 (" & F & ")").Range("B1:BL65000").ClearContents
For i = 1 To Sheets("Sayfa1").Range("A65536").End(xlUp).Row + 1
    Sheets("Sayfa1 (" & F & ")").Cells(i, 2).Value = Sheets("Sayfa1").Cells(i, F).Value
Next
Next
Sheets("Sayfa1").Select
End Sub

Dosyanız ekte,iyi çalışmalar.
not:kırmızı yazılan 63 sütun sayısı verileriniz daha fazla sütun olursa arttırın.

değerli katkılarından dolayı çok teşekkür ederim beni büyük bir dertten kurtardın eline sağlık

 

[jackal07]

Alternatif;

Sub SutunlariAyriSayfalaraKopyala()
sil
c = 1
son = Cells.SpecialCells(xlLastCell).Column - 1
For i = 2 To son
    Sheets.Add , ActiveSheet
    ActiveSheet.Name = "Sayfa" & i
    c = c + 1
    ActiveSheet.[a:a] = Sheets("Sayfa1").[a:a].Value
    ActiveSheet.Columns(2) = Sheets("Sayfa1").Columns(c).Value
Next
End Sub
Sub sil()
Application.DisplayAlerts = False
    For i = Sheets.Count To 1 Step -1
     If Sheets(i).Name <> "Sayfa1" Then Sheets(i).Delete
    Next
Application.DisplayAlerts = True
End Sub

dostum sanada teşekkür ederim ilginden dolayı çok sağolun