Hi,
This may not be complicated but after i read some of the forums, i have not found a solution. My problem is i have all my information on one sheet. My sheet has 3 columns of data, on column A it specifies a table (table 2, 3, 4, 5, etc...). Each Table has data below. What i am looking for is for each table and the data below the table to be in a different sheet. So if i have 20 tables, i will have 20 sheets. Would really appreciate the help?!!!
Re: Copy columns to different sheets
This code works on your sample workbook. If the Table Headers are really bold this should do the trick..... :
Sub Test()
Dim LngLp As Long
Dim LRow As Long
Dim BottomCll As Long
'Find last cell when dealing with empty cells in columns....
LRow = Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
BottomCll = LRow 'Define Bottom Cell of Table
For LngLp = LRow To 1 Step -1
If Cells(LngLp, "A").Font.Bold Then 'Look for table start cells by identifying them based on bold lettering
ActiveWorkbook.Sheets.Add Before:=Worksheets(Worksheets.Count) 'Add Worksheet
Sheets("Sheet1").Range("A" & LngLp & ":C" & BottomCll).Copy ActiveSheet.Range("A1") 'Copy Table Data to newly added worksheet
BottomCll = LngLp - 2 'Reset Bottom Cell of Table
End If
Next LngLp
End SubRe: Copy columns to different sheets
Hi mrmmickle1,
loooks good almost what i wanted. When i run the code it makes 2 sheets one with 1 table which is what i wanted and another sheet with the left over tables. Anyway to make it so that it populates 1 sheet with 1 table?
Thanks for the quick response!
Re: Copy columns to different sheets
Try this small modification:
Sub Test()
Dim LngLp As Long
Dim LRow As Long
Dim BottomCll As Long
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'Find last cell when dealing with empty cells in columns....
LRow = Sheets("Sheet1").Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
BottomCll = LRow 'Define Bottom Cell of Table
For LngLp = LRow To 1 Step -1
If Sheets("Sheet1").Cells(LngLp, "A").Font.Bold Then 'Look for table start cells by identifying them based on bold lettering
ActiveWorkbook.Sheets.Add Before:=Worksheets(Worksheets.Count) 'Add Worksheet
Sheets("Sheet1").Range("A" & LngLp & ":C" & BottomCll).Copy ActiveSheet.Range("A1") 'Copy Table Data to newly added worksheet
BottomCll = LngLp - 2 'Reset Bottom Cell of Table
End If
Next LngLp
Sheets("Sheet1").Delete
With Application
.ScreenUpdating = True
.DisplayAlerts = False
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End SubRe: Copy columns to different sheets
mrmmickle1 you are the man! Thank you for your support!
Re: Copy columns to different sheets
Glad you were able to get it working. Your'e welcome.
Don’t have an account yet? Register yourself now and be a part of our community!