troubleshooting Question

Split data in separate sheets - after changing the column from D to A macro has a problem

Avatar of Adam Elsheimer
Adam ElsheimerFlag for Germany asked on
Microsoft ExcelVBAMicrosoft Office
4 Comments1 Solution69 ViewsLast Modified:
Thanks goes to Subodh Tiwari (Neeraj). How I can modify the column range? If I change the column in the code from D to A the macro does not work correct. If I use as coded below it works great. What I am doing wrong? Which other parameters I have to change?

Thanks Regards

Sub SplitDataBasedOnColumnD()
Dim dataWS As Worksheet, WS As Worksheet
Dim dict, x
Dim i As Long, lr As Long

Application.ScreenUpdating = False
Set dataWS = Sheets("Database")
lr = dataWS.Cells(Rows.Count, 1).End(xlUp).Row

x = dataWS.Range("D2:D" & lr).Value
Set dict = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(x, 1)
    If x(i, 1) <> "" Then
        dict.Item(x(i, 1)) = ""
    End If
Next i

If dict.Count = 0 Then
    MsgBox "No data found in column D.", vbExclamation, "Data Not Found!"
    Exit Sub
End If

dataWS.AutoFilterMode = False
For Each it In dict.keys
    On Error Resume Next
    Set WS = Sheets(Replace(it, "/", "-"))
    WS.Cells.Clear
    On Error GoTo 0
    If WS Is Nothing Then
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = Replace(it, "/", "-")
        Set WS = ActiveSheet
    End If
    With dataWS.Rows(1)
        .AutoFilter field:=4, Criteria1:=it
        dataWS.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy WS.Range("A1")
        WS.Columns.AutoFit
        WS.Range("A1").CurrentRegion.Borders.Color = vbBlack
        Set WS = Nothing
    End With
Next it
dataWS.AutoFilterMode = False
dataWS.Activate
Application.ScreenUpdating = True
End Sub

Open in new window

ASKER CERTIFIED SOLUTION
Join our community to see this answer!
Unlock 1 Answer and 4 Comments.
Start Free Trial
Learn from the best

Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.

Andrew Hancock - VMware vExpert
See if this solution works for you by signing up for a 7 day free trial.
Unlock 1 Answer and 4 Comments.
Try for 7 days

”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.

-Mike Kapnisakis, Warner Bros