Kolonları Sayfalara Bölerken yaşanan sorun

[Trader3461]

Arkadaşlar merhaba, henüz forumda yeniyim. Bir sorum olacak yardımcı olabilirseniz sevinirim.

Bir Excel tablom var ve ben bu tabloda 6. sütundaki hücrelerin hepsini birer sheet olarak bölmek istiyorum. Ve böldükten sonra yine aynı sayfadaki kolonları sırasıyla 1-2, 1-3, 1-4, 1-5... 1-n şeklinde ilgili sayfalara kopyalamak istiyorum. kodu aşağıya ekliyorum. Yardımcı olabileceklere şimdiden teşekkürler.

Yine ilgili dosyayı da şu linkte paylaştım.

https://drive.google.com/open?id=1ZUvmRCOWLdQuPJvwfPdOqLWi8KIJCk4n

Sub ExtractToSheets()
Dim ws As Worksheet
Dim wsNew As Worksheet
Dim rData As Range
Dim rfl As Range
Dim state As String
Set ws = ThisWorkbook.Sheets("High")

With ws
Set rData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 11).End(xlUp))
.Columns(.Columns.Count).Clear
.Range(.Cells(2, 6), .Cells(.Rows.Count, 6).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True
'Calls Excel Advanced Filter
For Each rfl In .Range(.Cells(1, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))
state = rfl.Text

If WksExists(state) Then
Sheets(state).Cells.Clear
Else

Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = state
End If

rData.AutoFilter Field:=6, Criteria1:=state
rData.Copy Destination:=Worksheets(state).Cells(1, 1)
Next rfl
End With
ws.Columns(Columns.Count).ClearContents
rData.AutoFilter
End Sub

Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
'Excel advanced filter technique

 

[Trader3461]

Arkadaşlar yardımcı olabilecek kimse yok mu?