Split Workbook to Multiple Worksheets

[CorrieAnn Gillen]

I have struggled with this code for a while now. I got this snippet off of this site, but I don't understand how to alter it to suit my needs:

Sub copyPasteData()
  
  Dim strSourceSheet As String
  Dim strDestinationSheet As String
  Dim lastRow As Long
  
  strSourceSheet = "Data entry"
  
  Sheets(strSourceSheet).Visible = True
  Sheets(strSourceSheet).Select
  
  Range("C2").Select
  Do While ActiveCell.Value <> ""
  strDestinationSheet = ActiveCell.Value
  ActiveCell.Offset(0, -2).Resize(1, ActiveCell.CurrentRegion.Columns.Count).Select
  Selection.Copy
  Sheets(strDestinationSheet).Visible = True
  Sheets(strDestinationSheet).Select
  lastRow = LastRowInOneColumn("A")
  Cells(lastRow + 1, 1).Select
  Selection.PasteSpecial xlPasteValues
  Application.CutCopyMode = False
  Sheets(strSourceSheet).Select
  ActiveCell.Offset(0, 2).Select
  ActiveCell.Offset(1, 0).Select
  Loop
End Sub

Public Function LastRowInOneColumn(col)
  'Find the last used row in a Column: column A in this example
  'http://www.rondebruin.nl/last.htm
  Dim lastRow As Long
  With ActiveSheet
  lastRow = .Cells(.Rows.Count, col).End(xlUp).Row
  End With
  LastRowInOneColumn = lastRow
End Function

Specifically, my key column is Column A. That is where the rep names reside and where I need the workbook to do it's splitting. The code above uses column C, therefore this line adjust for column C:

ActiveCell.Offset(0, -2).Resize(1, ActiveCell.CurrentRegion.Columns.Count).Select

I have tried to change the offset to (0,0) but that didn't work. I am not sure how to work with this line.

I also get an error on this line, stating that it isn't defined:

Sheets(strDestinationSheet).Visible = True

Can someone help me? I just have a spreadsheet with data in columns A: AF that needs to be split out to individual sheet tabs based on rep name, which resides in column A.

Thank you so much!!

 

[Mike H..]

I have struggled with this code for a while now. I got this snippet off of this site, but I don't understand how to alter it to suit my needs:

Sub copyPasteData()

  Dim strSourceSheet As String
  Dim strDestinationSheet As String
  Dim lastRow As Long

  strSourceSheet = "Data entry"

  Sheets(strSourceSheet).Visible = True
  Sheets(strSourceSheet).Select

  Range("C2").Select
  Do While ActiveCell.Value <> ""
  strDestinationSheet = ActiveCell.Value
  ActiveCell.Offset(0, -2).Resize(1, ActiveCell.CurrentRegion.Columns.Count).Select
  Selection.Copy
  Sheets(strDestinationSheet).Visible = True
  Sheets(strDestinationSheet).Select
  lastRow = LastRowInOneColumn("A")
  Cells(lastRow + 1, 1).Select
  Selection.PasteSpecial xlPasteValues
  Application.CutCopyMode = False
  Sheets(strSourceSheet).Select
  ActiveCell.Offset(0, 2).Select
  ActiveCell.Offset(1, 0).Select
  Loop
End Sub

Public Function LastRowInOneColumn(col)
  'Find the last used row in a Column: column A in this example
  'http://www.rondebruin.nl/last.htm
  Dim lastRow As Long
  With ActiveSheet
  lastRow = .Cells(.Rows.Count, col).End(xlUp).Row
  End With
  LastRowInOneColumn = lastRow
End Function

Specifically, my key column is Column A. That is where the rep names reside and where I need the workbook to do it's splitting. The code above uses column C, therefore this line adjust for column C:

ActiveCell.Offset(0, -2).Resize(1, ActiveCell.CurrentRegion.Columns.Count).Select

I have tried to change the offset to (0,0) but that didn't work. I am not sure how to work with this line.

I also get an error on this line, stating that it isn't defined:

Sheets(strDestinationSheet).Visible = True

Can someone help me? I just have a spreadsheet with data in columns A: AF that needs to be split out to individual sheet tabs based on rep name, which resides in column A.

Thank you so much!!

Hi,

Try this code. It uses the rep name in column A as the sheet name to copy to. If the sheet doesn't exist then the code will create it.

Change the worksheet name in the code to the correct one that holds your raw data.

Sub Copy_Data()
Dim r As Range, LastRow As Long, ws As Worksheet
Dim v As Variant, s As String, LastRow1 As Long
Dim src As Worksheet
'Change this to the name of the sheet with the data on
Set src = Sheets("Sheet1")
LastRow = src.Cells(Cells.Rows.Count, "A").End(xlUp).Row
For Each r In src.Range("A2:A" & LastRow)
  On Error Resume Next
  Set ws = Sheets(CStr(r.Value))
  On Error GoTo 0
  If ws Is Nothing Then
  Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CStr(r.Value)
'If you want it this row copies the header from the source sheet 
' src.Rows(1).Copy ActiveSheet.Range("A1")  '<=== added line to copy headers
  LastRow1 = Sheets(CStr(r.Value)).Cells(Cells.Rows.Count, "A").End(xlUp).Row
  src.Rows(r.Row).Copy Sheets(CStr(r.Value)).Cells(LastRow1 + 1, 1)
  Set ws = Nothing
  Else
  LastRow1 = Sheets(CStr(r.Value)).Cells(Cells.Rows.Count, "A").End(xlUp).Row
  src.Rows(r.Row).Copy Sheets(CStr(r.Value)).Cells(LastRow1 + 1, 1)
  Set ws = Nothing
  End If
Next r
End Sub

 

[CorrieAnn Gillen]

You are a life saver!!!! Muah!