ワークシートに行を作成して追加する

Question

私はVBAコーディングを新しくしました。テンプレートを設定して、B列を参照するマクロを作成したいとします。次に、Bの異なる入力用の新しいワークシートを作成します。最後に、値が「B1」のすべての行を取り出し、対応するワークシートに挿入します。

（例が不明な場合）列Bには値1と2が含まれています。コードで「1」と「2」というワークシートが作成されます。その後、列Bの1を持つすべての行を取り出し、それらをワークシート "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

は（コメントとしてコード内の説明）以下のコードを試してみてください。

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