워크 시트에 행을 만들고 추가하십시오.

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