Solved

VB Macro Help Requested

Posted on 2012-12-21
6
247 Views
Last Modified: 2012-12-23
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
0
Comment
Question by:James0903
  • 3
  • 3
6 Comments
 
LVL 18

Expert Comment

by:krishnakrkc
ID: 38715089
Hi

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

Open in new window


Kris
0
 

Author Comment

by:James0903
ID: 38715845
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
0
 
LVL 18

Expert Comment

by:krishnakrkc
ID: 38715885
add these lines at the end of the code(before application.scr...)

ActiveWindow.View = xlPageBreakPreview
    wksResult.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1

Open in new window


Kris
0
Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

 

Author Comment

by:James0903
ID: 38716312
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.
0
 
LVL 18

Accepted Solution

by:
krishnakrkc earned 500 total points
ID: 38716557
Here you go.

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

Open in new window


Kris
0
 

Author Closing Comment

by:James0903
ID: 38717049
Kris, thank you very much!  Looks great...Saves me hours of manually entering the data into this new chart.  Happy Holidays and thank you again.
0

Featured Post

Networking for the Cloud Era

Join Microsoft and Riverbed for a discussion and demonstration of enhancements to SteelConnect:
-One-click orchestration and cloud connectivity in Azure environments
-Tight integration of SD-WAN and WAN optimization capabilities
-Scalability and resiliency equal to a data center

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Introduction This Article is a follow-up to my Mappit! Addin Article (http://www.experts-exchange.com/A_2613.html), it was inspired by an email posting I made to EUSPRIG (http://www.eusprig.org/index.htm), I will briefly cover: 1) An overvie…
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…
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

856 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question