CODEWITHSUNDEEP
vbaexcelexcel-2010
zach
zach

Reputation: 1361

Copy to New Worksheet when row is blank

PROBLEM

I need a macro that can copy from sheet1 to sheet[i] when i come across a blank line.

SAMPLE DATA

asdfasdf 1234
asdf 1234
gasdf 1234

asdf 1234 
asdf 1234 

fdas 1234
ds 1234

1234d 1234

RESULT

The macro should have taken that sample data and created 4 new sheets. Each grouping being its own spreadsheet.

CODE

I am somewhat new to VBA so I don't always understdan the code, but I did find this code that kind of works. I am unable to understand it enough to make it work.

 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

and another solution...

'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

Neither of which worked for me.

Thanks in advance

Upvotes: 0

Views: 188

Answers (1)

tigeravatar
tigeravatar

Reputation: 26640

Give this a try:

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

Upvotes: 1

Related Questions