asked on

Modify Macro Splitting data into multiple worksheets based on values in columns

Dear Experts,

first of all credit & thanks goes to Martin Liss, ID: 39433448 for this excellent macro.

It is working fine.

Currently, I have to split data into ws based on values in different columns (table headers). I am changing the column A to eg. B,C etc.(macro splitts only A) manually by openning the code or copying the header column to column A.

I would like activate the column or table header by clicking with computer mouse and run the macro or macro should asks for the title column.

Please find attached the Sample file with the macro included.

Help is much appreciated. Thank you very much in advance.

Regards,

Adam
Sample.xlsm

ASKER CERTIFIED SOLUTION

Martin Liss

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Adam Elsheimer

ASKER

Thank you very much indeed. I am glad that I found your macro after testing other macros without coding knowledge. It is so extremly user friendly an genial. Thanks again Martin.

Martin Liss

You're welcome and I'm glad I was able to help.

If you expand the “Full Biography” section of my profile you'll find links to some articles I've written that may interest you.

Marty - Microsoft MVP 2009 to 2016
Experts Exchange MVE 2015
Experts Exchange Top Expert Visual Basic Classic 2012 to 2016

Adam Elsheimer

ASKER

Thanks. I currently reading your contributions. I like your approaches and solutions.

Adam Elsheimer

ASKER

Hi Martin

Macro works fine. I am very happy. If I split a small table there is no problem. But I get an error message when I try to split a table with 50.000 rows. I am using Excel 2016. Please find attached my sample file with over 50.000 rows.

Thanks again

Regards

Adam
Error.xlsm

Martin Liss

Well the error is caused by the variable "i" being defined as Integer which has a limit of 32767. Changing it to Long corrects that problem but the workbook runs out of resources because (I think) you are trying to create too many sheets. In any case try this code which includes code to eliminate the necessity to ask for the header range.

Sub Split_Data_Into_Multiple_Worksheets_Based_On_Value_Column_A_ByMartinLiss_EE()
'//// Your code that instead of splitting the worksheet into several other worksheets just copies the whole content of first sheet onto other sheets

Dim LR As Long
Dim ws As Worksheet
Dim vcol, i As Long 'Integer
Dim icol As Long
Dim myarr As Variant
Dim title As Range 'String
Dim titlerow As Integer
Dim lngLastCol As Long
Dim strLastCol As String

'vcol = 1
vcol = ActiveCell.Column

 If MsgBox("Would you like to split data based on values in Column '" & Split(Cells(1, vcol).Address, "$")(1) & "'" _
          & " named '" & Cells(1, vcol) & "' in the current worksheet?", vbQuestion + vbYesNo, "Split worksheet based on values in Column A") = vbNo Then
        Exit Sub
        End If

Set ws = ActiveWorkbook.ActiveSheet
LR = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row

'lngLastColumn = Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, SearchDirection:=xlPrevious).Column
For lngLastCol = 1 To Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, SearchDirection:=xlPrevious).Column
    If Cells(1, lngLastCol) = Empty Then
        lngLastCol = lngLastCol - 1
        Exit For
    End If
Next
strLastCol = Split(Cells(1, lngLastCol).Address, "$")(1)


'title = "A1:L1" 'HARD CODED. Should be DYNAMIC
'On Error Resume Next
'Set title = Application.InputBox("Please enter the Title range", "Select Title Range", "A1:" & strLastCol & "1", Type:=8)
'If title Is Nothing Then
'    MsgBox "You pressed Cancel"
'    Exit Sub
'End If
'On Error GoTo 0
Set title = Range("A1:" & strLastCol & "1")

'titlerow = ws.Range(title).Cells(1).Row
titlerow = title.Row

icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To LR
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
'ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
ws.Range(title.Rows(1).Address).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""

If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Sheets(myarr(i) & "").Move After:=Worksheets(Worksheets.Count)
ws.Range("A" & titlerow & ":A" & LR).EntireRow.Copy Sheets(myarr(i) & "").Range("A4")
'Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub

Open in new window

Adam Elsheimer

ASKER

You are correct, I tried and tested to create 250 sheets.

Now, it works great. I would like to thank you for your rapid and efficient response.

I think I should divide the data in two parts.

Regards

Adam

Martin Liss

If you would post another question I'm sure someone would help you automate it so that it's done in 250 sheet chunks.