Pull data from workbook_A to create workbook_B and modify data

[mkseto]

New to VBA, hope someone can help to create a macro for the following task:

On a regular basis, I get a workbook_A that has the following layout:

I need to open a new workbook_B that would look like the following, then close workbook_A without saving, and name workbook_B as "Results Workbook":

In other words, for workbook_B:
- Create a header row with the various labels (ideally, bold the font and grey the cells)
- Column A would just be a count of data rows
- Column B would be the joint values of columns A/B/C from workbook_A (i.e. A&B&C)
- Column C would be values from column E of workbook_A
- Column D would be values from column D of workbook_A
- At the end (last row), insert text "Grand Total" in Column A and sum up the total of Column D per figure above

Hope someone can help, thanks.

 

[kevin9999]

OK, let's try this. Save the following code to a macro-enabled or binary Excel file. Run the code while your workbook_A is closed. It will ask you to find the file. See if it does what you want.

Option Explicit
Sub mkseto()
    Dim wbSrc As Workbook, wbDest As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lr As Long, Filename As String, i As Long, arrIn, arrOut
    Application.ScreenUpdating = False
    
    Filename = Application.GetOpenFilename
    Set wbSrc = Workbooks.Open(Filename)
    Set ws1 = ActiveSheet
    
    arrIn = ws1.Cells(1, 1).CurrentRegion
    ReDim arrOut(1 To UBound(arrIn), 1 To 4)
    For i = 1 To UBound(arrIn)
        arrOut(i, 1) = arrIn(i, 1) & arrIn(i, 2) & arrIn(i, 3)
        arrOut(i, 2) = arrIn(i, 5)
        arrOut(i, 3) = arrIn(i, 4)
    Next i
    
    wbSrc.Close 0
    Set wbDest = Workbooks.Add(1)
    Set ws2 = ActiveSheet
    ws2.Cells(1).Resize(1, 4).Value = Array("COUNT", "LABEL_1", "LABEL_2", "LABEL_3")
    ws2.Cells(2, 2).Resize(UBound(arrOut, 1), UBound(arrOut, 2)).Value = arrOut
    lr = ws2.Cells(Rows.Count, 2).End(xlUp).Row
    
    With ws2.Range("A2:A" & lr)
        .Formula = "=ROW()-1"
        .Value = .Value
    End With
    
    ws2.Cells(lr + 1, 1) = "GRAND TOTAL"
    ws2.UsedRange.Columns.AutoFit
    ws2.Cells(lr + 1, 4).FormulaR1C1 = "=sum(R2C4:R" & lr & "C4)"
    
    lr = lr + 1
    With ws2.Range("A1:D1")
        .Font.Bold = True
        .Interior.ThemeColor = xlThemeColorDark1
        .Interior.TintAndShade = -0.15
    End With
    
    With ws2.Range(ws2.Cells(lr, 1), ws2.Cells(lr, 4))
        .Font.Bold = True
        .Interior.ThemeColor = xlThemeColorDark1
        .Interior.TintAndShade = -0.15
    End With
    
    wbDest.SaveAs ThisWorkbook.Path & "\workbook_B.xlsx", FileFormat:=51
    Application.ScreenUpdating = True
End Sub

 

[mkseto]

OMG, this is totally amazing, THANK YOU so much!!!
There were a couple of things I didn't think of, wonder if you would be kind enough to take a look:
1) In column "B" of the output (i.e. referred as workbook_B above), I defined it as the merged results of A&B&C from the original workbook_A. In the sample workbook_A, I used all 3-digit numbers but it could actually vary between 1 to 4 digits, and I actually need to keep it as a 4-digit field after the merge, padded with leading zero. In other words, instead of the result in B2 being "FirstSecond999", it should really be "FirstSecond0999". I'm really sorry that I totally forgot that.
2) Instead of putting the macro in a separate Excel file, I would like to place in within workbook_A (i.e. instead of prompting for the file), say in a worksheet called "Convert". Would I be correct to just remove the following lines and replaced with a line to make "Convert" active? I tried that but I got an error (can't try until I get back home, but will try again and include the error message here).

Again, THANKS!!!

 

[kevin9999]

OMG, this is totally amazing, THANK YOU so much!!!
There were a couple of things I didn't think of, wonder if you would be kind enough to take a look:
1) In column "B" of the output (i.e. referred as workbook_B above), I defined it as the merged results of A&B&C from the original workbook_A. In the sample workbook_A, I used all 3-digit numbers but it could actually vary between 1 to 4 digits, and I actually need to keep it as a 4-digit field after the merge, padded with leading zero. In other words, instead of the result in B2 being "FirstSecond999", it should really be "FirstSecond0999". I'm really sorry that I totally forgot that.
2) Instead of putting the macro in a separate Excel file, I would like to place in within workbook_A (i.e. instead of prompting for the file), say in a worksheet called "Convert". Would I be correct to just remove the following lines and replaced with a line to make "Convert" active? I tried that but I got an error (can't try until I get back home, but will try again and include the error message here).

Again, THANKS!!!

The amended code below addresses your first point (easy fix). As for point 2, I've changed the code to reference "Sheet1" of the workbook containing the code. If that's not where you have your original data, change it to the correct sheet reference where I've marked it. Your original post also asked to close workbook_A after the data transfer. The code does this - if you change your mind, just delete the last line of code before the End Sub. If this satisfies your needs, please mark it as a Solution.

Option Explicit
Sub mkseto2()
    Dim wbSrc As Workbook, wbDest As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lr As Long, Filename As String, i As Long, arrIn, arrOut
    Application.ScreenUpdating = False
    
    Set ws1 = ThisWorkbook.Sheets("Sheet1")   '<<<< ~~~ CHANGE REFERENCE IF NEEDED
    
    arrIn = ws1.Cells(1, 1).CurrentRegion
    ReDim arrOut(1 To UBound(arrIn), 1 To 4)
    For i = 1 To UBound(arrIn)
        arrOut(i, 1) = arrIn(i, 1) & arrIn(i, 2) & Format(arrIn(i, 3), "0000")
        arrOut(i, 2) = arrIn(i, 5)
        arrOut(i, 3) = arrIn(i, 4)
    Next i
    
    Set wbDest = Workbooks.Add(1)
    Set ws2 = ActiveSheet
    ws2.Cells(1).Resize(1, 4).Value = Array("COUNT", "LABEL_1", "LABEL_2", "LABEL_3")
    ws2.Cells(2, 2).Resize(UBound(arrOut, 1), UBound(arrOut, 2)).Value = arrOut
    lr = ws2.Cells(Rows.Count, 2).End(xlUp).Row
    
    With ws2.Range("A2:A" & lr)
        .Formula = "=ROW()-1"
        .Value = .Value
    End With
    
    ws2.Cells(lr + 1, 1) = "GRAND TOTAL"
    ws2.UsedRange.Columns.AutoFit
    ws2.Cells(lr + 1, 4).FormulaR1C1 = "=sum(R2C4:R" & lr & "C4)"
    
    lr = lr + 1
    With ws2.Range("A1:D1")
        .Font.Bold = True
        .Interior.ThemeColor = xlThemeColorDark1
        .Interior.TintAndShade = -0.15
    End With
    
    With ws2.Range(ws2.Cells(lr, 1), ws2.Cells(lr, 4))
        .Font.Bold = True
        .Interior.ThemeColor = xlThemeColorDark1
        .Interior.TintAndShade = -0.15
    End With
    
    wbDest.SaveAs ThisWorkbook.Path & "\Results Workbook.xlsx", FileFormat:=51
    Application.ScreenUpdating = True
    ThisWorkbook.Close 0       '<<< ~~~ DELETE THIS IF YOU WANT workbook_A LEFT OPEN
End Sub

 

[mkseto]

Works perfectly, totally AMAZING (you and the macro). Can't thank you enough!!!!

 

[kevin9999]

Works perfectly, totally AMAZING (you and the macro). Can't thank you enough!!!!

Glad I could help, and thanks for the feedback ?

 

[mkseto]

Looking for help with some changes. A new column has now been added to source document Workbook_A (i.e. column "F"), which will contain a text entry. This now needs to be copied to the output file Workbook_B as column "C", pushing what were original columns "C" and "D" to now become "D" and "E".
I tried to run the working macro above line-by-line to see where I could modify the codes with no luck (I really don't have much VBA knowledge). Any help would be appreciated!!!

 

[kevin9999]

Try this:

Option Explicit
Sub mkseto3()
    Dim wbSrc As Workbook, wbDest As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lr As Long, Filename As String, i As Long, arrIn, arrOut
    Application.ScreenUpdating = False
    
    Set ws1 = ThisWorkbook.Sheets("Sheet1")   '<<<< ~~~ CHANGE REFERENCE IF NEEDED
    
    arrIn = ws1.Cells(1, 1).CurrentRegion
    ReDim arrOut(1 To UBound(arrIn), 1 To 5)
    For i = 1 To UBound(arrIn)
        arrOut(i, 1) = arrIn(i, 1) & arrIn(i, 2) & Format(arrIn(i, 3), "0000")
        arrOut(i, 2) = arrIn(i, 6)
        arrOut(i, 3) = arrIn(i, 5)
        arrOut(i, 4) = arrIn(i, 4)
    Next i
    
    Set wbDest = Workbooks.Add(1)
    Set ws2 = ActiveSheet
    ws2.Cells(1).Resize(1, 5).Value = Array("COUNT", "LABEL_1", "LABEL_2", "LABEL_3", "LABEL_4")
    ws2.Cells(2, 2).Resize(UBound(arrOut, 1), UBound(arrOut, 2)).Value = arrOut
    lr = ws2.Cells(Rows.Count, 2).End(xlUp).Row
    
    With ws2.Range("A2:A" & lr)
        .Formula = "=ROW()-1"
        .Value = .Value
    End With
    
    ws2.Cells(lr + 1, 1) = "GRAND TOTAL"
    ws2.UsedRange.Columns.AutoFit
    ws2.Cells(lr + 1, 5).FormulaR1C1 = "=sum(R2C5:R" & lr & "C5)"
    
    lr = lr + 1
    With ws2.Range("A1:E1")
        .Font.Bold = True
        .Interior.ThemeColor = xlThemeColorDark1
        .Interior.TintAndShade = -0.15
    End With
    
    With ws2.Range(ws2.Cells(lr, 1), ws2.Cells(lr, 5))
        .Font.Bold = True
        .Interior.ThemeColor = xlThemeColorDark1
        .Interior.TintAndShade = -0.15
    End With
    
    wbDest.SaveAs ThisWorkbook.Path & "\Results Workbook.xlsx", FileFormat:=51
    Application.ScreenUpdating = True
    ThisWorkbook.Close 0       '<<< ~~~ DELETE THIS IF YOU WANT workbook_A LEFT OPEN
End Sub

 

[mkseto]

Try this:

Again, you're totally amazing, just wish I could find a better way to thank you!!!!
Appreciate all your help!

 

[mkseto]

Just ran into a little problem ........ the codes above has been working well until today. I fugured out the cause but don't know how to fix it.
For as long as at least one of the input files contains a value in the last column "F", the macro works perfectly. However, today is the first time none of the files contained any value in column "F', and the macro returned a runtime error (out of range).
Any easy fix to accommodate such a scenario?