Copying partial rows and appending to the bottom of table loops

[jbraucht]

Top 'o the morning to you!

I've got an interesting task that I am trying to automate via the use of a macro. This task is currently done through a manual process and we are trying to speed up the process.

I am importing data from and SharePoint Network site into Excel so that I can display the information in a pivot table. Because of the way that the data is being imported, I am not able to have the pivot table simply do the work for me (at least as best as I can figure). The data that is being imported is information around training sessions and attendees that have been trained at different companies. Currently, the data imports several sessions on the same row and I am hoping to create unique rows of data for each session.

For example, this is what the header row looks like when it is imported, however, the sessions (columns K and greater) repeat up to session 5:

Excel Workbook
	D	E	F	G	H	I	J	K	L	M	N	O
1	Company	Learning Consultant	Session 1 Product Trained	Session 1 Training Method	Session 1 # of Sessions Held	Session 1 # of Employees Trained	Session 1 Completion Date	Session 2 Product Trained	Session 2 Training Method	Session 2 # of Sessions Held	Session 2 # of Employees Trained	Session 2 Completion Date
Sheet1

Excel 2003

It's important to note that some rows will only have data in the session 1 columns, where as others will have data all 5 session of the columns (25 columns in total). Session 1 info will always have values, however the remaining (sessions 2-sessions 5) may or may not have data.

My objective is to append to the bottom of the worksheet new rows that repeat the Company Name, Learning Consultant, Product Trained, Training Method, Sessions Held, Employees Trained, and Completion Date. The session numbers (1-5) do not have any meaning and do not need to be captured.

For example, if this is what the info looked like before the macro was run:

Excel Workbook
	D	E	F	G	H	I	J	K	L	M	N	O
1	Company	Learning Consultant	Session 1 Product Trained	Session 1 Training Method	Session 1 # of Sessions Held	Session 1 # of Employees Trained	Session 1 Completion Date	Session 2 Product Trained	Session 2 Training Method	Session 2 # of Sessions Held	Session 2 # of Employees Trained	Session 2 Completion Date
2	ABC Co	Black, James	Intro to ABC Co.	Webinar	1	28	3/19/2010
3	Joe's Company	Thomas, Steve	Advanced Sales	F2F	5	35	12/9/2010	Sales Basics	Webinar	3	40	12/28/2010
4	Expensive Workers Ltd.	Bundy, Al	Claims	F2F	3	6	10/22/2010
5	Irish Crme Coffees	Rogers, Mr.	Intro to Sweetners	Webinar	6	88	4/15/2010
6	Jerry's Repair	Davis, Annie	Basic Plumbing	Webinar	1	7	5/5/2010	Basics of Tile work	Webinar	1	12	6/16/2010
7	Tom's Hardware	Kent, Clark	Intro to Excel	Webinar	1	1	11/16/2010
8	Sue's Phone Emporium	Farve, Brent	Using the Jitterbug	F2F	6	11	6/1/2010
9	Agriculture Ltd	Daniels, Jack	Pre-planting best practices	F2F	4	15	1/15/2011
10	Atlantic Fun Sports	Thompson, Andrew	Deep Sea Kayaking Fundamentals	Webinar	1	352	1/21/2011
11
Sheet1

Excel 2003

After the macro, this is what would be displayed:

Excel Workbook
	D	E	F	G	H	I	J	K	L	M	N	O
1	Company	Learning Consultant	Session 1 Product Trained	Session 1 Training Method	Session 1 # of Sessions Held	Session 1 # of Employees Trained	Session 1 Completion Date	Session 2 Product Trained	Session 2 Training Method	Session 2 # of Sessions Held	Session 2 # of Employees Trained	Session 2 Completion Date
2	ABC Co	Black, James	Intro to ABC Co.	Webinar	1	28	3/19/2010
3	Joe's Company	Thomas, Steve	Advanced Sales	F2F	5	35	12/9/2010
4	Expensive Workers Ltd.	Bundy, Al	Claims	F2F	3	6	10/22/2010
5	Irish Crme Coffees	Rogers, Mr.	Intro to Sweetners	Webinar	6	88	4/15/2010
6	Jerry's Repair	Davis, Annie	Basic Plumbing	Webinar	1	7	5/5/2010
7	Tom's Hardware	Kent, Clark	Intro to Excel	Webinar	1	1	11/16/2010
8	Sue's Phone Emporium	Farve, Brent	Using the Jitterbug	F2F	6	11	6/1/2010
9	Agriculture Ltd	Daniels, Jack	Pre-planting best practices	F2F	4	15	1/15/2011
10	Atlantic Fun Sports	Thompson, Andrew	Deep Sea Kayaking Fundamentals	Webinar	1	352	1/21/2011
11	Joe's Company	Thomas, Steve	Sales Basics	Webinar	3	40	12/28/2010
12	Jerry's Repair	Davis, Annie	Basics of Tile work	Webinar	1	12	6/16/2010
Sheet1

Excel 2003

...notice that the yellow rows (rows 11 and 12) have copied from rows 3 and 6, columns D-E and K-O. The yellow is simply to highlight these areas and is not something that I am trying to add as part of my outcome.

I believe that the best way to accomplish this is to loop through the workbook and look to see if there is a value in each of the session columns and then append it to the bottom of the sheet, and repeat that for all of the sessions (2-5). I am struggling to get any where with this activity.

I am working in Excel 2003 on Windows XP SP3. I have searched the board and found several items on looping and conditional copying, however, I am not able take what I’ve found and mold it to meet my needs.

Thanks in advance for any help or suggestions that you might have!

 

[texasalynn]

edit: oops found a mistake - here is the corrected code

try this

Sub transpose_Sessions()
Dim LR As Long, ALC As Long, ALR As Long, i As Long
LR = ActiveSheet.Range("D" & Rows.Count).End(xlUp).Row
ALR = Range("K" & Rows.Count).End(xlUp).Row + 1
ALC = Range("IV1").End(xlToLeft).Column
Cells.AutoFilter
Columns("F:J").EntireColumn.Hidden = True
Cells.AutoFilter Field:=11, Criteria1:="<>"
Range("D3:O" & ALR).SpecialCells(xlCellTypeVisible).Select
Range("D3:O" & ALR).Copy Destination:=Range("D" & LR + 1)
Range("K3:O" & LR).ClearContents
Application.CutCopyMode = False
Cells.AutoFilter
Cells.EntireColumn.Hidden = False
Range("A1").Select
MsgBox "Done"
End Sub

 

[jbraucht]

TexasLynn -- This is exactly what I want to do! Thank you very much for your input.

As I mentioned in my original post, I have potentially 5 sessions worth of data that I want to append to the bottom of the sheets using this method. I would need to repeat your code to check for sessions 3-5. If I am reading the code properly, the code that I would need to repeat is between the Cells.AutoFilter lines, similar to this?

...
Cells.AutoFilter
Columns("F:O").EntireColumn.Hidden = True
Cells.AutoFilter Field:=16, Criteria1:="<>"
Range("D3:T" & ALR).SpecialCells(xlCellTypeVisible).Select
Range("D3:T" & ALR).Copy Destination:=Range("D" & LR + 1)
Range("O3:T" & LR).ClearContents
...

... and so on until I have done that for all 5 sessions?

 

[jbraucht]

I think this is what I am trying to do! Thanks again TexasLynn!

Sub transpose_Sessions()
Dim LR As Long, ALC As Long, ALR As Long, i As Long
LR = ActiveSheet.Range("D" & Rows.Count).End(xlUp).Row
ALR = Range("K" & Rows.Count).End(xlUp).Row + 1
ALC = Range("IV1").End(xlToLeft).Column
Cells.AutoFilter

Columns("F:J").EntireColumn.Hidden = True
Cells.AutoFilter Field:=11, Criteria1:="<>"
Range("D3:O" & ALR).SpecialCells(xlCellTypeVisible).Select
Range("D3:O" & ALR).Copy Destination:=Range("D" & LR + 1)
Range("K3:O" & LR).ClearContents
Cells.EntireColumn.Hidden = False
Application.CutCopyMode = False

LR = ActiveSheet.Range("D" & Rows.Count).End(xlUp).Row
ALR = Range("P" & Rows.Count).End(xlUp).Row + 1
ALC = Range("IV1").End(xlToLeft).Column

Columns("F:O").EntireColumn.Hidden = True
Cells.AutoFilter Field:=16, Criteria1:="<>"
Range("D3:T" & ALR).SpecialCells(xlCellTypeVisible).Select
Range("D3:T" & ALR).Copy Destination:=Range("D" & LR + 1)
Range("O3:T" & LR).ClearContents
Application.CutCopyMode = False

Cells.AutoFilter
Cells.EntireColumn.Hidden = False
Range("A1").Select
MsgBox "Done"
End Sub

 

[texasalynn]

Your welcome - you've got it basically. I'm sure someone else could make it even more streamlined to loop through the 5 different sessions. But it works


BTW - you need to inclose your code with the code tags. Makes it much easier to read your posts

 

[jbraucht]

TexasLynn - Thanks again for your help!

Okay, one last question if I might... Below is the final code that I ended up with for this task (with code tags... thanks for the suggestion, I didn't know what they did previously!). Currently, it is running as expected assuming there is at least one row of data found when you do the auto filter to non-blank fields.

However, if there is not any data found (for example, if there are no training sessions listed in the Session 5 fields), I get an error: "Run-time error '1004': No cells were found." Is there a way that I can tell it to skip to the end of the macro if that error is encountered?

Thanks again for your help!

SSub transpose_Sessions()
Dim LR As Long, ALC As Long, ALR As Long, i As Long

'=============================================================
'Start of session 2
LR = ActiveSheet.Range("D" & Rows.Count).End(xlUp).Row
ALR = Range("K" & Rows.Count).End(xlUp).Row + 1
ALC = Range("IV1").End(xlToLeft).Column
Cells.AutoFilter

Columns("F:J").EntireColumn.Hidden = True
Cells.AutoFilter Field:=11, Criteria1:="<>"
Range("D3:O" & ALR).SpecialCells(xlCellTypeVisible).Select
Range("D3:O" & ALR).Copy Destination:=Range("D" & LR + 1)
Range("K3:O" & LR).ClearContents
Cells.EntireColumn.Hidden = False
Application.CutCopyMode = False
'End of session 2
'=============================================================


'=============================================================
'Start of session 3
LR = ActiveSheet.Range("D" & Rows.Count).End(xlUp).Row
ALR = Range("P" & Rows.Count).End(xlUp).Row + 1 'update "P" to reflect the start of the next group of sessions
ALC = Range("IV1").End(xlToLeft).Column

Columns("F:O").EntireColumn.Hidden = True
Cells.AutoFilter Field:=16, Criteria1:="<>"
Range("D3:T" & ALR).SpecialCells(xlCellTypeVisible).Select
Range("D3:T" & ALR).Copy Destination:=Range("D" & LR + 1)
Range("O3:T" & LR).ClearContents
Application.CutCopyMode = False
Cells.EntireColumn.Hidden = False
Application.CutCopyMode = False
'End of session 3
'=============================================================

'=============================================================
'Start of session 4 (not yet complete)
LR = ActiveSheet.Range("D" & Rows.Count).End(xlUp).Row
ALR = Range("T" & Rows.Count).End(xlUp).Row + 1 'update "P" to reflect the start of the next group of sessions
ALC = Range("IV1").End(xlToLeft).Column

Columns("F:T").EntireColumn.Hidden = True 'Update to hide "F:?" where ? is the cell before the start of session 4
Cells.AutoFilter Field:=21, Criteria1:="<>" 'update autofilter field number to the proper column number
Range("D3:Y" & ALR).SpecialCells(xlCellTypeVisible).Select 'update "D3:?" to the reflect the proper column letter
Range("D3:Y" & ALR).Copy Destination:=Range("D" & LR + 1) 'same as above
Range("T3:Y" & LR).ClearContents 'update to clear the contents of session 4 data
Application.CutCopyMode = False
Cells.EntireColumn.Hidden = False
Application.CutCopyMode = False
'End of session 4
'=============================================================

'=============================================================
'Start of session 5
LR = ActiveSheet.Range("D" & Rows.Count).End(xlUp).Row
ALR = Range("Z" & Rows.Count).End(xlUp).Row + 1
ALC = Range("IV1").End(xlToLeft).Column

Columns("F:Y").EntireColumn.Hidden = True
Cells.AutoFilter Field:=26, Criteria1:="<>"
Range("D3:AD" & ALR).SpecialCells(xlCellTypeVisible).Select
Range("D3:AD" & ALR).Copy Destination:=Range("D" & LR + 1)
Range("Z3:AD" & LR).ClearContents
Application.CutCopyMode = False
Cells.EntireColumn.Hidden = False
Application.CutCopyMode = False
'End of session 5
'=============================================================


Cells.AutoFilter
Cells.EntireColumn.Hidden = False
Range("A1").Select
MsgBox "Done"
End Sub

 

[texasalynn]

add this after the ALR line

If ALR >2 Then
.code here for that session
End If

 

[jbraucht]

add this after the ALR line

If ALR >2 Then
.code here for that session
End If

You rock! Many, many thanks!