Zerlegen einer Tabelle in mehrere Blätter nach Spalte

Question

Ich bin derzeit versucht, eine Möglichkeit zum Aufspalten eines 10000 Artikel Blatt für Spalte. Ich verwende den Code im folgenden Link.

https://www.extendoffice.com/documents/excel/1174-excel-split-data-into-multiple-worksheets-based-on-column.html

Aber ich habe Probleme bekommen es zu arbeiten. Ich weiß nicht, wie ich programmieren soll, aber ich weiß, wie man den Anweisungen folgt. Dies ist mein Code, nach Änderungen

Sub parse_data() 
Dim lr As Long 
Dim ws As Worksheet 
Dim vcol, i As Integer 
Dim icol As Long 
Dim myarr As Variant 
Dim title As String 
Dim titlerow As Integer 
vcol = 15 
Set ws = Sheets("Sheet1") 
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row 
title = "01:Z1" 
titlerow = ws.Range(title).Cells(1).Row 
icol = ws.Columns.Count 
ws.Cells(1, icol) = "Unique" 
For i = 2 To lr 
On Error Resume Next 
If ws.Cells(i, vcol) <> "" And  Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0  Then 
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol) 
End If 
Next 
myarr =  Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellType Constants)) 
ws.Columns(icol).Clear 
For i = 2 To UBound(myarr) 
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & "" 
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then 
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & "" 
Else 
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count) 
End If 
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) &  "").Range("A1") 
Sheets(myarr(i) & "").Columns.AutoFit 
Next 
ws.AutoFilterMode = False 
ws.Activate 
End Sub 

auf der Website zufolge, soll ich meine ausgebreiteten oben von den verschiedenen Namen in meiner O Spalte (dh department1, Abteilung 2, usw.) werden geteilt wird. Jedoch bekomme ich Fehler 1004 zurück. Ich denke, dass dies vielleicht der vcol Wert ist (Ich gebe 15, weil O der 15. Buchstabe im Alphabet ist). Könnte mir hier jemand helfen? Danke im Voraus.

Answer 1

Der Code scheint für mich gut zu funktionieren, ich gebe Ihnen einige Schritte, um zu überprüfen, was es tut.

Sie können zu einer Zeile gehen, drücken Sie F9 und es wird einen Unterbrechungspunkt, wo der Code stoppt, und Sie können sehen, was los ist.

Dieser Teil sollte eine Liste in der letzten Spalte des Blattes (Spalte XFD wahrscheinlich) mit allen eindeutigen Werten aus Ihrer ausgewählten Spalte erstellen und dann in einem Array speichern. Machen Sie eine Pause in der letzten Zeile und stellen Sie sicher, dass Sie diese Liste haben.

ws.Cells(1, icol) = "Unique" 
For i = 2 To lr 
On Error Resume Next 
If ws.Cells(i, vcol) <> "" And  Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0  Then 
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol) 
End If 
Next 
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants)) 

Dieser einen Filter auf Ihre Daten gilt, so dass es nur die gefilterten Daten kopieren können (Sie tun Sie nicht eine leere zweiten Reihe haben.

ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & "" 

Dieses ein neues Blatt und Kopien erstellt die Daten über

If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then 
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & "" 
Else 
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count) 
End If 
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1") 

Der einzige Grund kann ich glaube, dass alle Daten kopiert werden würde, wenn es nicht richtig gefiltert werden. So versuchen, einen Filter manuell hinzufügen und sehen, was es tut.