Разделить данные на одном листе на несколько листов на основе столбца в Excel с помощью vba

Question

Я пытаюсь разбить данные на листе 1 на несколько листов на основе столбца имен в ячейке A3 и далее. Проблема, с которой я сталкиваюсь, - я не могу отслеживать данные, если между ними есть промежуток. Например, имя начинается с 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 

Answer 1

Вот несколько менее оптимизирован, но проще следовать версии:

Private Sub CommandButton1_Click() 

Dim ws As Worksheet, c As Range 
Dim temp As Worksheet, CostC As Range, u 

Set ws = Sheets("Sheet1") 

Set CostC = ws.Range(ws.Range("A3"), ws.Range("A" & Rows.Count).End(xlUp)) 

For each c in CostC.Cells 

    u = trim(c.Value) 
    If len(u) > 0 then 

     Set temp = Nothing '<<EDIT 
     On Error Resume Next 
     Set temp = Sheets(u) 
     On Error GoTo 0 

     If temp is Nothing then 
      Set temp = Sheets.Add() 
      ws.Range("A2").Resize(1, 15).Copy temp.range("a1") 'copy headers 
      temp.Name = u 
     End If 

     c.resize(1, 15).copy temp.cells(rows.count,1).end(xlup).offset(1,0) 

    End if 'have name 

Next c 
End Sub 

Answer 2

Используйте метод ColumnDifferences возвращать диапазон, а затем использовать Areas(1) свойство этого диапазона, чтобы скопировать данные в новую рабочий лист, а затем вы можете удалить данные и повторить или пропустить области и скопировать их.