Создание и добавление строк в рабочий лист

Question

Я довольно новичок в кодировании VBA. Я хочу создать шаблон и хотел бы создать макрос, который смотрит на столбец B. Затем создает новые рабочие листы для разных входов в B. Наконец, он вытягивает все строки со значением «B1» и помещает их в соответствующий рабочий лист.

(Пример, если неясно) Столбец B включает значения 1 и 2. Затем код создает рабочие листы, называемые «1» и «2». Затем берут все строки, которые имеют 1 в столбце B, и помещают их в рабочий лист «1» и аналогичны для значения «2».

Sub Sheet() 
    Dim NewSheet As Worksheet 
    Dim cell As Object 
    Dim cellRange As Long 

    For Each Worksheets("ImportSheet") In [Column J] 
     Set NewSheet = Nothing 
     On Error Resume Next 
     Set NewSheet = Worksheets(rng.Value) 
     On Error GoTo 0 
     If NewSheet Is Nothing Then 
      Worksheets.Add(After:=Sheets(Sheets.Count)).Name = rng.Value 
     End If 
    Next rng 
End Sub 

Спасибо

Answer 1

Try код ниже (пояснения внутри кода в комментариях):

Option Explicit 

Sub Sheet() 

Dim lRow As Long 
Dim Dict As Object 
Dim Key  As Variant 
Dim LastRow As Long 
Dim DestSht As Worksheet 
Dim ShtName As String 

Set Dict = CreateObject("Scripting.Dictionary") 

With Worksheets("ImportSheet") 

    ' loop from row 2 until last row with data in Column "B" 
    For lRow = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row   
     ' copy unique values from column B into dictionary 
     If Not Dict.exists(.Range("B" & lRow).value) Then 
      If .Range("B" & lRow).value <> "" Then Dict.Add .Range("B" & lRow).value, .Range("B" & lRow).value 
     End If 
    Next lRow 

    ' create a new worksheet per unique key in Dictionary 
    For Each Key In Dict 
     Worksheets.Add(After:=Sheets(Sheets.Count)).Name = Key 
    Next Key 

    ' loop through all cells in Column B, and copy each row to relevant worksheet 
    For lRow = .Cells(.Rows.Count, "B").End(xlUp).Row To 2 Step -1 
     If .Range("B" & lRow).value <> "" Then 
      ShtName = .Range("B" & lRow).value 
      Set DestSht = Worksheets(ShtName) 
      LastRow = DestSht.Cells(DestSht.Rows.Count, "B").End(xlUp).Row + 1 
      .Rows(lRow).Copy Destination:=DestSht.Range("A" & LastRow) 
      .Rows(lRow).Delete xlShiftUp 
     End If 
    Next lRow 
End With 

End Sub 

Answer 2

И это то, что я имел для движущихся строк:

Dim contract As String 
Imprt = Worksheets("ImportSheet").UsedRange.Rows.Count 
    Srtd = Worksheets(contract)"enter code here" 
    If Srtd = 1 Then Srtd = 0 
    For x = Imprt To 2 Step -1 
     If Range("J" & x).Value = contract Then 
      Rows(x).Cut Destination:=Worksheets(contract).Range("A" & Srtd + 1) 
      Srtd = Srtd + 1 
      Else: 
     End If 
    Next x