구분 기호 VBA로 새 시트의 셀 복사

Question

VBA에서 매크로를 사용하여 해결하려는 Excel에서이 문제가 있습니다.

separator 
1 
2 
6 
3 
8 
342 
532 
separator 
72 
28 
10 
21 
separator 
38 
23 
234 

내가하고 싶은 것은 모든 데이터의 일련의 (일련는 "분리"에서 시작하고 끝을위한 새로운 시트를 만드는 VBA 매크로를 작성하는 것입니다 :이 형식의 데이터가 포함 된 시트가 다음 시트 앞 또는 첫 번째 시트의 끝)를 선택하고 새 시트에 각각의 데이터를 복사하십시오. 예 :

72 
28 
10 
21 

시트 1

에서

1 
2 
6 
3 
8 
342 
532 

에서 시트 2 등 대단히 감사합니다, 나는 그것을 감사! 첫 번째 분리 ("Q")에 처음부터 이 데이터를 복사 :

Sub macro1() 
Dim x As Integer 
x = 1 

Sheets.Add.Name = "Sheet2" 

'Get cells until first q 

Do Until Sheets("Sheet1").Range("A" & x).Value = "q" 
Sheets("Sheet2").Range("A" & x).Value = Sheets("Sheet1").Range("A" & x).Value 
x = x + 1 
Loop 


End Sub 

Answer 1

이 시도 ... (안된)

Const sep As String = "q" 

Sub Sample() 
    Dim ws As Worksheet, wsNew As Worksheet 
    Dim lRow As Long, i As Long, rw As Long 

    '~~> Set this to the relevant worksheet 
    Set ws = ThisWorkbook.Sheets("Sheet1") 
    '~~> Add a new temp sheet 
    Set wsNew = ThisWorkbook.Sheets.Add 

    '~~> Set row for the new output sheet 
    rw = 1 

    With ws 
     '~~> Get the last row 
     lRow = .Range("A" & .Rows.Count).End(xlUp).Row 

     '~~> Loop through the cells from row 2 
     '~~> assuming that row 1 has a spearator 
     For i = 2 To lRow 
      If .Range("A" & i).Value = sep Then 
       Set wsNew = ThisWorkbook.Sheets.Add 
       rw = 1 
      Else 
       wsNew.Cells(rw, 1).Value = .Range("A" & i).Value 
       rw = rw + 1 
      End If 
     Next i 
    End With 
End Sub 

Answer 2

당신은 모든 행을 반복하지 않도록하려면이 옵션을 사용할 수 있습니다. 원본 데이터도 삭제하고 싶을 때만 가능합니다.

SubSample() 
Dim x As Integer 
Dim FoundCell As Range 
Dim NumberOfQs As Long 
Dim SheetWithData As Worksheet 
Dim CurrentData As Range 

Set SheetWithData = Sheets("Sheet4") 
NumberOfQs = WorksheetFunction.CountIf(SheetWithData.Range("A:A"), "q") 

x = 1 


Set FoundCell = SheetWithData.Range("A1", SheetWithData.Range("A" & Rows.Count)).Find("q", , , , , xlPrevious) 

If Not FoundCell Is Nothing Then 
    Set LastCell = FoundCell.End(xlDown) 
    Set CurrentData = SheetWithData.Range(FoundCell, LastCell) 
    Sheets.Add.Name = "QSheetNumber" & x 'Get cells until first q 
    CurrentData.Cut Sheets("QSheetNumber" & x).Range("A1") 
    Sheets("QSheetNumber" & x).Rows(1).Delete 
    x = x + 1 
    Set FoundCell = SheetWithData.Range("A1", SheetWithData.Range("A" & Rows.Count)).Find("q", FoundCell, , , , xlPrevious) 
    If Not FoundCell Is Nothing Then 
     Set LastCell = FoundCell.End(xlDown) 
     Set CurrentData = SheetWithData.Range(FoundCell, LastCell) 
     Sheets.Add.Name = "QSheetNumber" & x 'Get cells until first q 
     CurrentData.Cut Sheets("QSheetNumber" & x).Range("A1") 
     Sheets("QSheetNumber" & x).Rows(1).Delete 
     x = x + 1 
    Else 
     Exit Sub 
    End If 
Else 
    Exit Sub 
End If 

End Sub