Separating data and placing in individual worksheets Excel VBA

[Kmahraz]

Hello,
I have a large data set , this data is all contained in a single worksheet. I wish excel to separate the data according to column "A"then place each value in a separate worksheet in the same workbook and named the same as the name in column A.
I found this code and would like to see if someone can help me fix and make it work to meet my needs.
Regards,
K

Sub SplitData()Dim DataMarkers(), Names As Range, name As Range, n AsLong, i AsLong

Set Names = Range("A2:A"& Range("A1").End(xlDown).Row)
n =0

DeleteWorksheets

ForEach name In NamesIf name.Offset(1,0)<> name ThenReDimPreserve DataMarkers(n)
DataMarkers(n)= name.Row
Worksheets.Add(After:=Worksheets(Worksheets.Count)).name = name
n = n +1EndIfNext name

For i =0To UBound(DataMarkers)If i =0Then
Worksheets(1).Range("A2:C"& DataMarkers(i)).Copy Destination:=Worksheets(i +2).Range("A1")Else
Worksheets(1).Range("A"&(DataMarkers(i -1)+1)&":C"& DataMarkers(i)).Copy Destination:=Worksheets(i +2).Range("A1")EndIfNext i
EndSub

Sub DeleteWorksheets()Dim ws As Worksheet, activeShtIndex AsLong, i AsLong

activeShtIndex = ActiveSheet.Index

Application.DisplayAlerts =FalseFor i = ThisWorkbook.Worksheets.Count To1Step-1If i <> activeShtIndex Then
Worksheets(i).Delete
EndIfNext i
Application.DisplayAlerts =TrueEndSub

 

[Kmahraz]

I was able to find a code that work, unfortunately it doesn't copy the headers, can any one help please.

Sub Button290_Click()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 1
Set ws = Sheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A2:GK2"
titlerow = ws.Range(title).Cells(1).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) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A2)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A2")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub

 

[Chihiro]

First issue. You have merged cell in Row 1 & 2.

Avoid use of merged cell, it's gonna cause a lot of headache for very minor cosmetic benefit.

Try running the code after un-merging Row 1 & 2 and see if the code works as intended.

 

[Kmahraz]

Hello Chihiro,
Thank you for your help, unfortunately I need the cells to be merged because there's specific data that goes into those cells, can you please assist?
Thanks
K

 

[Marc L]

Hi !​

I found this code and would like to see if someone can help me fix

Copy / Paste is not coding ‼

Need to fix ? So it's a bad code for your purpose !
Better is to burn couples of neurones, avoiding a gas factory code !

UNMERGE cells ! It's the worse habit to code in VBA !
Use instead center across cells format …
​

 

[Kmahraz]

Mark, thanks for the feedback ! I will try your recommendation and keep you guys posted.

 

[Chihiro]

Yep, merged cells are evil I tell ya.

But if you must... following is code with modification to the one you posted to accommodate for merged headers (will skip over them).

Sub Button290_Click()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 1
Set ws = Sheets("For Client")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A2:GK2"
titlerow = ws.Range(title).Cells(1).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) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A2)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A3:A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A3")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub

Then here's the code to paste merged header rows to each sheet created.

Sub CopyHeader()
Dim ws As Worksheet
    Sheets("For Client").Select
    Rows("1:2").Select
    Selection.Copy

For Each ws In ThisWorkbook.Worksheets
    If ws.name <> "For Client" Then
        ws.Range("A1").PasteSpecial
        ws.Columns.AutoFit
    End If
Next
Application.CutCopyMode = False
End Sub

 

[Kmahraz]

Thank you so much Chihiro!
I really appreciate you help, I will give it a try and keep you updated.
Regards,
K

 

[Chihiro]

Oh, you will want to adjust width of each column as merged cells do not work well with .Autofit.

 

[Kmahraz]

Hello Chihido,
The second code work perfectly, for the first one some how it does copy and sort but only up to column GD vs GK,
Regards
K

 

[Chihiro]

I think your issue is that you have multiple hidden columns.

My code ignores hidden columns and grab data from there as well. But the code you supplied may not. Just unhide all columns before you run the code and you should be good.

I'll not have access to internet most of the day. If you have other questions, I'll try to get to them later.

 

[Kmahraz]

Hello Chihiro,
Thank you so much for the code, it worked perfectly.
Regards,
K