VBA to Split Workbook into tabs/worksheets using data in Column

sush23

New Member
Joined
Aug 8, 2011
Messages
24
Hi there,

I have the following code which works wonders as it stands right now (thanks goes to user #VoG ). I would like to modify it so that the data that is populated in the tabs and workbooks does not include Col. A which is the same column that I'm using to extract by. I've tried for a couple hours thinking it would be an easy fix by redefining the Last Col. but it has not worked. I'd really appreciate any help!! Note: I also have another module (Public Type BrowseInfo) that goes with this code.

Code:
Sub MLEXTRACTION()Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String, Folder As String, Fname As String
On Error Resume Next
Set r = Application.InputBox("Click in the column to extract by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
With ActiveSheet
    Master = .Name
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To LastRow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = Format(.Cells(iStart, iCol).Value, "mmyy")
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Completed in " & Format(Now - t, "hh:mm:ss.00"), vbInformation
If MsgBox("Do you want to save the separated sheets as workbooks", vbYesNo + vbQuestion) = vbYes Then
    Folder = "Select the folder to save the workbooks"
    Folder = GetDirectory(Folder)
    If Folder = "" Then Exit Sub
    Prefix = InputBox("Enter a prefix (or leave blank)")
    Application.ScreenUpdating = False
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> Master Then
            sh.Copy
            Fname = Folder & "\" & Prefix & sh.Name
            If Dir(Fname) <> "" Then Fname = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.csv), *.csv)", _
                Title:=Fname & " exists - select file to save as")
            ActiveWorkbook.SaveAs Filename:=Fname, FileFormat:=xlCSV
            ActiveWorkbook.Close
        End If
     Next sh
     Application.ScreenUpdating = True
End If
End Sub
 

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
I think it's this one...
Code:
 ws.Range(Cells(1, 2), Cells(1, LastCol)).Value = .Range(.Cells(1, 2), .Cells(1, LastCol)).Value
perhaps this one as well..
Code:
.Range(.Cells(2, 2), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
HTH. Dave
 
Last edited:
Upvote 0
I think it's this one...
Rich (BB code):
 ws.Range(Cells(1, 2), Cells(1, LastCol)).Value = .Range(.Cells(1, 2), .Cells(1, LastCol)).Value
perhaps this one as well..
Rich (BB code):
.Range(.Cells(2, 2), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
HTH. Dave


Hi Dave,

Thank you for your help!! Unfortunately, I got errors on both those codes. I replaced this part of the code
Code:
[COLOR=#574123].Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
[/COLOR][COLOR=#574123]        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom[/COLOR]
with yours and I get two different errors for each of them. The first says "The sort reference is not valid. Make sure it's within the data you want to sort and the first sort by box isn't the same or blank. The other says "Object variable or With Block variable not set"

Again I appreciate your help!

Rachel
 
Upvote 0
" I would like to modify it so that the data that is populated in the tabs and workbooks does not include Col. A " So, do you don't want to have data in "A" or U just don't want to transfer the data from A or both? Right now you are sorting the range A2:lastrow&lastcol by whatever column is selected. U are then adding a sheet and transferring A1: A& lastrow to the new sheet. Then U are copying the range A & rowstart: lastcol & rowend to the new sheet. There's a lot of "A"s in there. Dave
 
Last edited:
Upvote 0
" I would like to modify it so that the data that is populated in the tabs and workbooks does not include Col. A " So, do you don't want to have data in "A" or U just don't want to transfer the data from A or both? Right now you are sorting the range A2:lastrow&lastcol by whatever column is selected. U are then adding a sheet and transferring A1: A& lastrow to the new sheet. Then U are copying the range A & rowstart: lastcol & rowend to the new sheet. There's a lot of "A"s in there. Dave


Hey Dave!

Haha there are a lot of A's there, to answer your first question, I just don't want to transfer the data from A, but I would like to have the data copied over starting in A. If it makes things easier, I could have the data in A, that I don't want transferred, in another column maybe to the right of the data that will always end in Col. Q (included). So if I could get the macro to copy over all the data from A-Q with every change in say the data in Col. R, that would work too. I was trying to think through that idea yesterday, let me know what you think!

Thank you!
 
Last edited:
Upvote 0
I was close with this...
Code:
ws.Range(Cells(1, 2), Cells(1, LastCol)).Value = .Range(.Cells(1, 2), .Cells(1, LastCol)).Value
This seems like it should be the one..
Code:
ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 2), .Cells(1, LastCol)).Value
This stops the transfer of A and transfers over only B1: whatever&1 The rest of it shouldn't need change as U were already transferring A. Trial it out. Dave
 
Upvote 0
I was close with this...
Code:
ws.Range(Cells(1, 2), Cells(1, LastCol)).Value = .Range(.Cells(1, 2), .Cells(1, LastCol)).Value
This seems like it should be the one..
Code:
ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 2), .Cells(1, LastCol)).Value
This stops the transfer of A and transfers over only B1: whatever&1 The rest of it shouldn't need change as U were already transferring A. Trial it out. Dave

Hey Dave,

I just did, but for some reason it still gives me an error "Object variable or With block variable not set. Here's the code as it stands right now (with your changes), maybe I replaced the wrong thing? Would appreciate you taking a look and I certainly appreciate your help!


Code:
Sub MLEXTRACTION()Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String, Folder As String, Fname As String
On Error Resume Next
Set r = Application.InputBox("Click in the column to extract by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
With ActiveSheet
    Master = .Name
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 2), .Cells(1, LastCol)).Value
    iStart = 2
    For i = 2 To LastRow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = Format(.Cells(iStart, iCol).Value, "mmyy")
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Completed in " & Format(Now - t, "hh:mm:ss.00"), vbInformation
If MsgBox("Do you want to save the separated sheets as workbooks", vbYesNo + vbQuestion) = vbYes Then
    Folder = "Select the folder to save the workbooks"
    Folder = GetDirectory(Folder)
    If Folder = "" Then Exit Sub
    Prefix = InputBox("Enter a prefix (or leave blank)")
    Application.ScreenUpdating = False
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> Master Then
            sh.Copy
            Fname = Folder & "\" & Prefix & sh.Name
            If Dir(Fname) <> "" Then Fname = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.csv), *.csv)", _
                Title:=Fname & " exists - select file to save as")
            ActiveWorkbook.SaveAs Filename:=Fname, FileFormat:=xlCSV
            ActiveWorkbook.Close
        End If
     Next sh
     Application.ScreenUpdating = True
End If
End Sub
Thanks
Rachel
 
Upvote 0
Hi Rachel. I should have specified where. Trial this..
Code:
Sub MLEXTRACTION()
Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String, Folder As String, Fname As String
On Error Resume Next
Set r = Application.InputBox("Click in the column to extract by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
With ActiveSheet
    Master = .Name
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To LastRow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = Format(.Cells(iStart, iCol).Value, "mmyy")
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 2), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
End Sub
 
Upvote 0
Hi Rachel. I should have specified where. Trial this..
Code:
Sub MLEXTRACTION()
Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String, Folder As String, Fname As String
On Error Resume Next
Set r = Application.InputBox("Click in the column to extract by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
With ActiveSheet
    Master = .Name
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To LastRow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = Format(.Cells(iStart, iCol).Value, "mmyy")
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 2), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
End Sub


Hey Dave,

We're getting closer. This code has no errors, but it still pulls the data in Col. A and also gives me an #N/A in the label in last col. of data. Also I don't have CoL. A label populated and the extractions does move the labeling to start from Col. A, but the data underneath is still in the column A in the extractions.
Thanks for your help!
Rachel
 
Upvote 0
Well I guess this is next...
Code:
.Range(.Cells(2, 2), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Dave
 
Upvote 0

Forum statistics

Threads
1,223,098
Messages
6,170,103
Members
452,302
Latest member
TaMere

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top