bonescoster
New member
- Joined
- May 15, 2015
- Messages
- 2
- Reaction score
- 0
- Points
- 0
Hey everyone.
I have been searching for a couple days now to see if anyone has asked this question but I could not find the answer. I was able to get code that will split the data in one worksheet and move it into separate (already existing) worksheets. However what I am trying to do now is to have a table of data split into other tables based on a column value. For Example: if column A = SLC then move it to the table named "SLC".
This is the code that I have used to move the information from a worksheet to multiple worksheets based on column A. Could anyone help me tweek this to work or provide different code that will work? S
Any help would be great. Thanks.
I have been searching for a couple days now to see if anyone has asked this question but I could not find the answer. I was able to get code that will split the data in one worksheet and move it into separate (already existing) worksheets. However what I am trying to do now is to have a table of data split into other tables based on a column value. For Example: if column A = SLC then move it to the table named "SLC".
This is the code that I have used to move the information from a worksheet to multiple worksheets based on column A. Could anyone help me tweek this to work or provide different code that will work? S
Code:
ub Sort()
'
' Sort Macro
Dim sh As Worksheet, ws As Worksheet, lr As Long, lc As Long, rng As Range, c As Range
Set sh = Sheets("Detail Data")
lr = sh.Cells(Rows.Count, 3).End(xlUp).Row
lc = sh.Cells.Find("*", , xlFormulas, xlPart, xlByColumns, xlPrevious).Column
sh.Range("A1:A" & lr).AdvancedFilter xlFilterCopy, , sh.Range("A" & lr + 2), True
Set rng = sh.Range("A" & lr + 3, sh.Cells(Rows.Count, 1).End(xlUp))
For Each c In rng
Set ws = Sheet(c.Value)
sh.Range("A1", sh.Cells(lr, lc)).AutoFilter 3, c.Value
sh.Range("A2", sh.Cells(lr, lc)).SpecialCells(xlCellTypeVisible).Copy ws.Range("A4")
Next
sh.AutoFilterMode = False
sh.Range("A" & lr + 2, sh.Cells(Rows.Count, 1).End(xlUp)).Delete
End Sub
