我正在尝试根据单元格 A3 中的名称列将工作表 1 中的数据拆分为多个工作表。我面临的问题是,如果两者之间存在差距,我将无法追踪数据。示例名称从 A3 到 A100 开始,在单元格 A10、A20 和 A30 之间为空,程序将仅跟踪从 A3 到 A9 的值。我的另一个问题是指定标题。我要使用的标题从单元格 A2、B2、C2 和 D2 开始,该程序将标题显示为 A1、B1、C1 和 D1,因为该单元格中有值。这是我的代码。
Private Sub CommandButton1_Click()
Dim ws As Worksheet, Rng As Range, cc
Dim temp As Worksheet, CostC As Range, u
Set ws = Sheets("Sheet1") 'where your original data. adjust to suit
Set Rng = ws.Range("a1").CurrentRegion.Resize(, 15)
Set CostC = ws.Range("a3", ws.Range("a" & Rows.Count).End(xlUp))
u = UNIQUE(CostC)
Application.ScreenUpdating = 0
For Each cc In u
With Rng
.AutoFilter field:=1, Criteria1:="=" & cc
On Error Resume Next
Set temp = Sheets(cc)
On Error GoTo 0
If Not temp Is Nothing Then
DoThis:
.SpecialCells(xlCellTypeVisible).Copy temp.Range("A1")
Else
Set temp = Sheets.Add
temp.Name = cc
GoTo DoThis
End If
.AutoFilter
End With
Set temp = Nothing
Next
Application.ScreenUpdating = 1
End Sub
Function UNIQUE(r As Range)
Dim a, v
If IsArray(r.Value) Then
a = r.Value
With CreateObject("scripting.dictionary")
.comparemode = vbTextCompare
For Each v In a
If Not IsEmpty(v) Then
If Not .exists(v) Then .Add v, Nothing
End If
Next
If .Count > 0 Then UNIQUE = .keys
End With
Erase a
Else
UNIQUE = r.Value
End If
End Function