0

问题

当我遇到空白行时，我需要一个可以从 sheet1 复制到 sheet[i] 的宏。

样本数据

asdfasdf 1234
asdf 1234
gasdf 1234

asdf 1234 
asdf 1234 

fdas 1234
ds 1234

1234d 1234

结果

宏应该获取该样本数据并创建 4 个新工作表。每个分组都是它自己的电子表格。

代码

我对 VBA 有点陌生，所以我并不总是了解代码，但我确实发现这种代码有效。我无法充分理解它以使其工作。

 Sub CreateNewWorksheets()
  Dim lLoop As Long, lLoopStop As Long
  Dim rMove As Range, wsNew As Worksheet

  Set rMove = ActiveSheet.UsedRange.Columns(1)
  lLoopStop = WorksheetFunction.CountIf(rMove, "Category")
  For lLoop = 1 To lLoopStop
  Set wsNew = Sheets.Add
  rMove.Find("Category", rMove.Cells(1, 1), xlValues, _
  xlPart, , xlNext, False).CurrentRegion.Cut _
  Destination:=wsNew.Cells(1, 1)
  wsNew.UsedRange.Columns.AutoFit
 Next lLoop
End Sub

和另一个解决方案......

'Split File up by blank sections
Application.ScreenUpdating = False
For Each c In ActiveSheet.Range("A:C").SpecialCells(xlCellTypeConstants).Areas
    c.Copy Destination:=Worksheets.Add(After:=Sheets(Sheets.Count)).Range("A1")
Next c

两者都不适合我。

提前致谢

4

1 回答 1

1

试试这个：

Sub CreateNewWorksheets()

    Dim rngStart As Range
    Dim rngEnd As Range

    Set rngStart = Range("A1")
    If Len(rngStart.Text) = 0 Then Set rngStart = rngStart.End(xlDown)

    Do
        Select Case (Len(rngStart.Offset(1).Text) = 0)
            Case True:  Set rngEnd = rngStart
            Case Else:  Set rngEnd = rngStart.End(xlDown)
        End Select
        Range(rngStart, rngEnd).EntireRow.Copy Sheets.Add(After:=Sheets(Sheets.Count)).Range("A1")
        Set rngStart = rngEnd.End(xlDown)
    Loop While rngStart.Row < Rows.Count

    Set rngStart = Nothing
    Set rngEnd = Nothing

End Sub
于 2013-08-08T20:43:12.770 回答