We value your feedback.
Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!
Course Of The Month
6 days, 4 hours left to enrollBecome a Premium Member and unlock a new, free course in leading technologies each month.
Solved
VB Macro Help Requested
Posted on 2012-12-21
Sir/Madam,
I am requesting assistance with the coding of a VB macro. Please see attached spreadsheet. In the attached, a macro was created to copy data from the 'CSV' tab into the 'Template' tab (upon running, the final result would appear in the 'Results' tab). The current macro is written for Part I - Fleet (the first table in the 'template' tab, rows 14-49).
Our customers now require additional information for each airline customer. They want to see the employee count. In the 'template' tab I created another table, Part II - Fleet and Personnel (rows 53-63). Unfortunately, my programmer cannot provide the data set needed for Parts I & II in one Excel spreadsheet, thus, tab 'CSV2' has data for Part II.
Can the current macro be updated so that when it runs, it continues to place the data for Part I into the first table, and then places the data for Part II into the second table?
I have attempted to update the program, and had no luck at all (it would embarassing to place it online that is how bad it was!). The "Current Results" is what the code is currently doing. The "Desired Results" is what I am trying to accomplish. When it is completed, each airline should only have 1 page. Though in there are only two airlines of data in the attached, this spreadsheet will be used for 100+ airlines.
Please advise with any questions. Thank you as always for your help!
Attached: My Excel spreadsheet and a Word file with the current macro code.
ExpertsExchange-Question-20.xlsm
ExpertsExchange-Question-20.docx
I am requesting assistance with the coding of a VB macro. Please see attached spreadsheet. In the attached, a macro was created to copy data from the 'CSV' tab into the 'Template' tab (upon running, the final result would appear in the 'Results' tab). The current macro is written for Part I - Fleet (the first table in the 'template' tab, rows 14-49).
Our customers now require additional information for each airline customer. They want to see the employee count. In the 'template' tab I created another table, Part II - Fleet and Personnel (rows 53-63). Unfortunately, my programmer cannot provide the data set needed for Parts I & II in one Excel spreadsheet, thus, tab 'CSV2' has data for Part II.
Can the current macro be updated so that when it runs, it continues to place the data for Part I into the first table, and then places the data for Part II into the second table?
I have attempted to update the program, and had no luck at all (it would embarassing to place it online that is how bad it was!). The "Current Results" is what the code is currently doing. The "Desired Results" is what I am trying to accomplish. When it is completed, each airline should only have 1 page. Though in there are only two airlines of data in the attached, this spreadsheet will be used for 100+ airlines.
Please advise with any questions. Thank you as always for your help!
Attached: My Excel spreadsheet and a Word file with the current macro code.
ExpertsExchange-Question-20.xlsm
ExpertsExchange-Question-20.docx
[X]
Welcome to Experts Exchange
Add your voice to the tech community where 5M+ people just like you are talking about what matters.
- Help others & share knowledge
- Earn cash & points
- Learn & ask questions
-
3
-
3
6 Comments
Active 3 days ago
Hi
try this
Kris
try this
Sub kTest()
Dim wksResult As Worksheet
Dim wksTemplate As Worksheet
Dim wksCSV1 As Worksheet
Dim wksCSV2 As Worksheet
Dim rngTemplate As Range
Dim rngCSV1 As Range
Dim rngCSV2 As Range
Dim rngAirC As Range
Dim rngDest As Range
Dim rngCopy As Range
Dim r As Long, c As Long
Dim dic As Object, t
Dim i As Long, AirC, PartII
Application.ScreenUpdating = 0
Set wksTemplate = Worksheets("Template")
Set rngTemplate = wksTemplate.Range("A1:T65")
Set wksCSV1 = Worksheets("CSV")
Set wksCSV2 = Worksheets("CSV2")
Set rngAirC = wksCSV1.Range("a1").CurrentRegion.Columns(1)
AirC = UNIQUE(rngAirC.Value2)
Set dic = CreateObject("scripting.dictionary")
dic.comparemode = 1
On Error Resume Next
Set wksResult = Worksheets("Result")
If Err.Number <> 0 Then
Set wksResult = Worksheets.Add
wksResult.Name = "Result"
End If
Err.Clear: On Error GoTo 0
wksResult.UsedRange.Clear
Set rngDest = wksResult.Cells(1)
PartII = wksTemplate.Range("b55:g63").Value2
For i = 1 To UBound(PartII, 1)
If Len(PartII(i, 1)) Then dic.Item(PartII(i, 1)) = i
Next
If IsArray(AirC) Then
wksCSV1.Rows(1).Insert
wksCSV1.Columns(11).Insert
wksCSV1.Cells(1, 11) = "temp"
wksCSV1.UsedRange.Rows(1) = "temp"
wksCSV2.Rows(1).Insert
wksCSV2.Columns(5).Insert
wksCSV2.Cells(1, 5) = "temp"
wksCSV2.UsedRange.Rows(1) = "temp"
rngTemplate.Copy
rngDest.PasteSpecial 8: Application.CutCopyMode = False
For i = LBound(AirC) To UBound(AirC)
rngTemplate.Copy rngDest
Union(rngDest.Cells(6, 18), rngDest.Cells(52, 3)) = "AIRLINE" & i + 1 & "-(" & AirC(i) & ")"
With wksCSV1.UsedRange.Resize(, 21)
.AutoFilter 1, AirC(i)
Set rngCopy = .Cells(1, 3).Offset(1).Resize(.Rows.Count - 1, .Columns.Count - 2).SpecialCells(12)
rngCopy.Copy
rngDest.Cells(23, 2).PasteSpecial -4163
Application.CutCopyMode = False
.AutoFilter
End With
Set rngCopy = Nothing
With wksCSV2.UsedRange.Resize(, 7)
.AutoFilter 1, AirC(i)
Set rngCopy = .Cells(1, 4).Offset(1).Resize(.Rows.Count - 1, .Columns.Count - 3).SpecialCells(12)
For r = 1 To rngCopy.Rows.Count
t = dic.Item(rngCopy.Cells(r, 1).Value)
If Not IsEmpty(t) Then
For c = 2 To rngCopy.Columns.Count
rngDest.Cells(54 + t, c + 1) = rngCopy.Cells(r, c).Value
Next
End If
Next
.AutoFilter
End With
Set rngCopy = Nothing
rngDest.Rows(53).RowHeight = 50
On Error Resume Next
rngDest.Cells(23, 2).Resize(27).SpecialCells(4).EntireRow.Delete
On Error GoTo 0
Set rngDest = wksResult.Range("b" & wksResult.Rows.Count).End(xlUp).Offset(3, -1)
wksResult.HPageBreaks.Add rngDest
Next
wksCSV1.Columns(11).Delete
wksCSV1.Rows(1).Delete
wksCSV2.Columns(5).Delete
wksCSV2.Rows(1).Delete
ElseIf Not IsEmpty(AirC) Then
wksCSV1.Columns(11).Insert
wksCSV5.Columns(5).Insert
rngTemplate.Copy rngDest
Union(rngDest.Cells(6, 18), rngDest.Cells(52, 3)) = "AIRLINE" & i + 1 & "-(" & AirC(i) & ")"
With wksCSV1.Range("a1").CurrentRegion
.AutoFilter 1, AirC(i)
Set rngCopy = .Cells(1, 3).Offset(1).Resize(.Rows.Count - 1, .Columns.Count - 2).SpecialCells(12)
rngCopy.Copy
rngDest.Cells(2, 23).PasteSpecial -4163
Application.CutCopyMode = False
.AutoFilter
End With
Set rngCopy = Nothing
With wksCSV2.Range("a1").CurrentRegion
.AutoFilter 1, AirC(i)
Set rngCopy = .Cells(1, 4).Offset(1).Resize(.Rows.Count - 1, .Columns.Count - 3).SpecialCells(12)
For r = 1 To rngCopy.Rows.Count
t = dic.Item(rngCopy.Cells(r, 1).Value)
If Not IsEmpty(t) Then
For c = 2 To rngCopy.Columns.Count
rngDest.Cells(54 + t, c + 1) = rngCopy.Cells(r, c).Value
Next
End If
Next
.AutoFilter
End With
Set rngCopy = Nothing
rngDest.Rows(53).RowHeight = 50
On Error Resume Next
rngDest.Cells(23, 2).Resize(27).SpecialCells(4).EntireRow.Delete
On Error GoTo 0
Set rngDest = wksResult.Range("b" & wksResult.Rows.Count).End(xlUp).Offset(2)
wksResult.HPageBreaks.Add rngDest
wksCSV1.Columns(11).Delete
wksCSV2.Columns(5).Delete
End If
Application.ScreenUpdating = 1
End Sub
Private Function UNIQUE(ByRef d)
If TypeOf d Is Range Then d = d.Value2
Dim i As Long
With CreateObject("scripting.dictionary")
.comparemode = 1
For i = 1 To UBound(d, 1)
If Len(d(i, 1)) Then .Item(d(i, 1)) = Empty
Next
If .Count Then UNIQUE = .keys
End With
End Function
Kris
Kris, this is great, thank you. Is there a way we can make one page per airline? Right now the output for one airline is spread among, it looks like in the Print Preview, 6 pages. Other than that, it looks fantastic! Great job! Thanks!
I have attached the file again that ran with your code. Also attached is the updated macro code (this was one very tiny mistake in your macro code that I fixed, you had called the second tab CSV5 instead of CSV2, no worries, I fixed and it ran).
ExpertsExchange-Question-20.xlsm
ExpertsExchange-Question-20Updat.docx
I have attached the file again that ran with your code. Also attached is the updated macro code (this was one very tiny mistake in your macro code that I fixed, you had called the second tab CSV5 instead of CSV2, no worries, I fixed and it ran).
ExpertsExchange-Question-20.xlsm
ExpertsExchange-Question-20Updat.docx
Active 3 days ago
add these lines at the end of the code(before application.scr...)
Kris
ActiveWindow.View = xlPageBreakPreview
wksResult.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
Kris
Kris, very good, thank you. At first I was little confused by what you were trying to accomplish but then I realized where I was.
My last request is that the Airline Name is not actually "AIRLINE1", "AIRLINE2", etc. but instead actually United States airline carriers such as "Delta Airlines", "American Airlines", etc. When using Experts-Exchange, I cannot provide the actual name of the airline carriers so I just use dummy airline names. Next time I will use different 'fake' airline names for the Experts to understand.
Other than that, everything works! Great job. Thank you.
My last request is that the Airline Name is not actually "AIRLINE1", "AIRLINE2", etc. but instead actually United States airline carriers such as "Delta Airlines", "American Airlines", etc. When using Experts-Exchange, I cannot provide the actual name of the airline carriers so I just use dummy airline names. Next time I will use different 'fake' airline names for the Experts to understand.
Other than that, everything works! Great job. Thank you.
Active 3 days ago
Here you go.
Kris
Dim objUNQ As Object
Sub kTest()
Dim wksResult As Worksheet
Dim wksTemplate As Worksheet
Dim wksCSV1 As Worksheet
Dim wksCSV2 As Worksheet
Dim rngTemplate As Range
Dim rngCSV1 As Range
Dim rngCSV2 As Range
Dim rngAirC As Range
Dim rngDest As Range
Dim rngCopy As Range
Dim r As Long, c As Long
Dim dic As Object, t
Dim i As Long, AirC, PartII
Application.ScreenUpdating = 0
Set wksTemplate = Worksheets("Template")
Set rngTemplate = wksTemplate.Range("A1:T65")
Set wksCSV1 = Worksheets("CSV")
Set wksCSV2 = Worksheets("CSV2")
Set rngAirC = wksCSV1.Range("a1").CurrentRegion.Range("a:b")
AirC = UNIQUE(rngAirC.Value2)
Set dic = CreateObject("scripting.dictionary")
dic.comparemode = 1
On Error Resume Next
Set wksResult = Worksheets("Result")
If Err.Number <> 0 Then
Set wksResult = Worksheets.Add
wksResult.Name = "Result"
End If
Err.Clear: On Error GoTo 0
wksResult.UsedRange.Clear
wksResult.ResetAllPageBreaks
Application.Goto wksResult.Cells(1)
ActiveWindow.View = xlNormalView
Set rngDest = wksResult.Cells(1)
PartII = wksTemplate.Range("b55:g63").Value2
For i = 1 To UBound(PartII, 1)
If Len(PartII(i, 1)) Then dic.Item(PartII(i, 1)) = i
Next
If IsArray(AirC) Then
wksCSV1.Rows(1).Insert
wksCSV1.Columns(11).Insert
wksCSV1.Cells(1, 11) = "temp"
wksCSV1.UsedRange.Rows(1) = "temp"
wksCSV2.Rows(1).Insert
wksCSV2.Columns(5).Insert
wksCSV2.Cells(1, 5) = "temp"
wksCSV2.UsedRange.Rows(1) = "temp"
rngTemplate.Copy
rngDest.PasteSpecial 8: Application.CutCopyMode = False
For i = LBound(AirC(0)) To UBound(AirC(0))
rngTemplate.Copy rngDest
Union(rngDest.Cells(6, 18), rngDest.Cells(52, 3)) = AirC(1)(i) & "-(" & AirC(0)(i) & ")"
With wksCSV1.UsedRange.Resize(, 21)
.AutoFilter 1, AirC(0)(i)
Set rngCopy = .Cells(1, 3).Offset(1).Resize(.Rows.Count - 1, .Columns.Count - 2).SpecialCells(12)
rngCopy.Copy
rngDest.Cells(23, 2).PasteSpecial -4163
Application.CutCopyMode = False
.AutoFilter
End With
Set rngCopy = Nothing
With wksCSV2.UsedRange.Resize(, 7)
.AutoFilter 1, AirC(0)(i)
Set rngCopy = .Cells(1, 4).Offset(1).Resize(.Rows.Count - 1, .Columns.Count - 3).SpecialCells(12)
For r = 1 To rngCopy.Rows.Count
t = dic.Item(rngCopy.Cells(r, 1).Value)
If Not IsEmpty(t) Then
For c = 2 To rngCopy.Columns.Count
rngDest.Cells(54 + t, c + 1) = rngCopy.Cells(r, c).Value
Next
End If
Next
.AutoFilter
End With
Set rngCopy = Nothing
rngDest.Rows(53).RowHeight = 50
On Error Resume Next
rngDest.Cells(23, 2).Resize(27).SpecialCells(4).EntireRow.Delete
On Error GoTo 0
Set rngDest = wksResult.Range("b" & wksResult.Rows.Count).End(xlUp).Offset(3, -1)
wksResult.HPageBreaks.Add rngDest
Next
wksCSV1.Columns(11).Delete
wksCSV1.Rows(1).Delete
wksCSV2.Columns(5).Delete
wksCSV2.Rows(1).Delete
ElseIf Not IsEmpty(AirC(0)) Then
wksCSV1.Columns(11).Insert
wksCSV2.Columns(5).Insert
rngTemplate.Copy rngDest
Union(rngDest.Cells(6, 18), rngDest.Cells(52, 3)) = AirC(1)(i) & "-(" & AirC(0)(i) & ")"
With wksCSV1.Range("a1").CurrentRegion
.AutoFilter 1, AirC(0)(i)
Set rngCopy = .Cells(1, 3).Offset(1).Resize(.Rows.Count - 1, .Columns.Count - 2).SpecialCells(12)
rngCopy.Copy
rngDest.Cells(2, 23).PasteSpecial -4163
Application.CutCopyMode = False
.AutoFilter
End With
Set rngCopy = Nothing
With wksCSV2.Range("a1").CurrentRegion
.AutoFilter 1, AirC(0)(i)
Set rngCopy = .Cells(1, 4).Offset(1).Resize(.Rows.Count - 1, .Columns.Count - 3).SpecialCells(12)
For r = 1 To rngCopy.Rows.Count
t = dic.Item(rngCopy.Cells(r, 1).Value)
If Not IsEmpty(t) Then
For c = 2 To rngCopy.Columns.Count
rngDest.Cells(54 + t, c + 1) = rngCopy.Cells(r, c).Value
Next
End If
Next
.AutoFilter
End With
Set rngCopy = Nothing
rngDest.Rows(53).RowHeight = 50
On Error Resume Next
rngDest.Cells(23, 2).Resize(27).SpecialCells(4).EntireRow.Delete
On Error GoTo 0
Set rngDest = wksResult.Range("b" & wksResult.Rows.Count).End(xlUp).Offset(2)
wksResult.HPageBreaks.Add rngDest
wksCSV1.Columns(11).Delete
wksCSV2.Columns(5).Delete
End If
ActiveWindow.View = xlPageBreakPreview
wksResult.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
Application.ScreenUpdating = 1
End Sub
Private Function UNIQUE(ByRef d)
If TypeOf d Is Range Then d = d.Value2
Dim i As Long
If objUNQ Is Nothing Then
Set objUNQ = CreateObject("scripting.dictionary")
objUNQ.comparemode = 1
Else
objUNQ.RemoveAll
End If
With objUNQ
For i = 1 To UBound(d, 1)
If Len(d(i, 1)) Then objUNQ.Item(d(i, 1)) = d(i, 2)
Next
If objUNQ.Count Then UNIQUE = Array(objUNQ.keys, objUNQ.items)
End With
End Function
Kris
Featured Post
We value your feedback.
Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!
Question has a verified solution.
If you are experiencing a similar issue, please ask a related question
Workbook link problems after copying tabs to a new workbook?
David Miller (dlmille)
Intro
Have you either copied sheets to a new workbook, and after having saved and opened that workbook, you find that there are links back to the original sou…
Access developers frequently have requirements to interact with Excel (import from or output to) in their applications. You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.
Suggested Courses
Course of the Month6 days, 4 hours left to enroll
705 members asked questions and received personalized solutions in the past 7 days.
Join the community of 500,000 technology professionals and ask your questions.