Pull data from workbook_A to create workbook_B and modify data

M

mkseto

New Member
Joined
Aug 14, 2018
Messages
38
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:
Workbook_A.gif


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":
Workbook_B.gif


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.
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
Sort by date Sort by votes
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.

VBA Code: 
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
 
Upvote 0
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!!!
 
Upvote 0
mkseto said:
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!!!
Click to expand...
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.

VBA Code: 
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
 
Upvote 0
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!!!
 
Upvote 0
Try this:

VBA Code: 
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
 
Upvote 0
Solution
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?
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
pulling data from changing cells
Replies
5
Views
131
Micron
M
franklin_m
  • Question
VBA Search row for instances of pattern in two adjacent cells
Replies
3
Views
131
franklin_m
franklin_m
M
  • Question
Getting Cell Values Changing Frequently and Rearranging it in a Compact Manner
Replies
7
Views
170
maeyks
M
T
  • Question
Pull data from multiple sheets that match varying criteria
Replies
0
Views
42
T1991
T
MrDB4Excel
  • Solved
Disregard Negative Results
Replies
3
Views
79
Joe4
Joe4

Forum statistics

Threads
1,215,248
Messages
6,123,867
Members
449,130
Latest member
lolasmith

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top