Question

我目前正试图找出一种按列细分10000项目表的方法。我正在使用以下链接中的代码。

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

但是，我无法让它工作。我不知道如何编码，但我知道如何遵循指示。在编辑后，这是我的代码

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

根据网站的说法，我应该按照我的O栏中的不同名称（即department1，department2等）将我的电子表格分开。但是，我得到了错误1004.我认为这可能是vcol值（我把15放，因为O是字母表中的第15个字母）。这里的任何人都可以帮助我吗？提前谢谢。

Answer 1

代码似乎对我有用，我会给你一些步骤来检查它的作用。

你可以按一行按f9，它会创建一个断点，代码将停止，你可以看到最新情况。

此部分应在工作表的最后一列（可能是XFD列）中创建一个列表，其中包含所选列中的所有唯一值，然后将其保存在数组中。在最后一行休息一下，确保你有这个清单。

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))

这会对您的数据应用过滤器，因此它只能复制过滤后的数据（您没有第二行空白。

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")

我认为所有数据都将被复制的唯一原因是它没有正确过滤。因此，请尝试手动添加过滤器并查看其功能。

按列将电子表格细分为多个工作表

1 个答案: