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

创建和添加行到工作表

2 个答案: