VBA code to get data from one workbook to another

karen02

New Member
Joined
Sep 15, 2021
Messages
15
Office Version
  1. 2019
Platform
  1. Windows
Hi guys,

I badly need a help.
Can somebody help me create a code to count the quantity of different data from one workbook (WB1) and bring that quantity to another workbook (WB2) with multiple sheets.

WB1 with one worksheet (WS1)
In Column A, it contains locations "L1", "L2", "L3", "L4" and so on....
In Column B, it contains information such as "pump", "valve", "tx" and so on...
In Column C, it contains information such as N1, N2 and N3.

WB2:
Planning to create a template where the following data will get populated and create a code to automatically create multiple sheets with locations "L1", "L2"... as its worksheet names.

WS1 "L1":
Pump - how many?
Valve - how many?
Tx - ho many?
Nx - how many? (In L1, there can be N1, N2 and N3 so I need to get qty "3". In L2, if N1, N2 are present, I need to get qty "2".


Same data need to be populated to WS2 "L2", WS3 "L3"

Any workaround on this?

Help, pleaseeeee.
Thank you very much in advance.
 

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
2,005
Office Version
  1. 2016
Platform
  1. Windows
Here is my understanding.
You have data in wb1 like your posted sample.
You wan to run the program and you will get the result in another workbook (wb2) with the template shown.
You will have 13 Material to summarize together with nodes
The sheet L1, L2 and so on will be segregate by different sheets

I'm ready to go to bed now because obviously I'm probably halfway across the world 😁
I think this is not difficult since the hardest part has been solved. I can get it done tomorrow if time permit.
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.

karen02

New Member
Joined
Sep 15, 2021
Messages
15
Office Version
  1. 2019
Platform
  1. Windows
Here is my understanding.
You have data in wb1 like your posted sample.
You wan to run the program and you will get the result in another workbook (wb2) with the template shown.
You will have 13 Material to summarize together with nodes
The sheet L1, L2 and so on will be segregate by different sheets

I'm ready to go to bed now because obviously I'm probably halfway across the world 😁
I think this is not difficult since the hardest part has been solved. I can get it done tomorrow if time permit.
Hi Zot.
Yes you are right. That's how it will be like. :)

Yeah, I think so. I am in +8 zone :ROFLMAO:.
Thank you so much for you efforts!! Appreciated!!
 

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
2,005
Office Version
  1. 2016
Platform
  1. Windows
This is how new macro works.

The macro is in wb1 with Sheet1 having list of data to compile. In wb1 also you will have another sheet called Template where you will have the template you showed me.
Location at K6
Node at H14
Material1 to Material13 from H41 to H53

You can list the Material in any order and the program will put the Qty next to corresponding Material.

Once the program run, a wb2 (you can name it as you like. See remark in macro) is created and sheets will be created when needed with a copy of Template from wb1. I hope this works flawlessly.
VBA Code:
Sub Summarize()

Dim key1 As String, key2 As String, Add As String
Dim Loc As String, wb2Name As String
Dim nRow As Long
Dim key As Variant
Dim cell As Range, rngFound As Range
Dim rngLoc As Range, rngMat As Range
Dim ws1 As Worksheet, ws2 As Worksheet, wsTmp As Worksheet
Dim wb1 As Workbook, wb2 As Workbook
Dim dictMat As Object, dictN As Object

Set dictMat = CreateObject("Scripting.Dictionary")
Set wb1 = ActiveWorkbook
Set ws1 = wb1.Sheets("Sheet1")
Set wsTmp = wb1.Sheets("Template")

Application.ScreenUpdating = False

' Set wb2 name here
wb2Name = "WB2"

Set wb2 = NewWorkbook(wb1.Path & "\", wb2Name, 1)
Set rngLoc = ws1.Range("A2", ws1.Cells(Rows.Count, "A").End(xlUp))

dictMat.RemoveAll
For Each cell In rngLoc
    key1 = cell.Value & " " & cell.Offset(, 1).Value
    key2 = cell.Value & " " & cell.Offset(, 2).Value
    If dictMat.Exists(key1) Then
        dictMat(key1) = dictMat(key1) + 1
    Else
        dictMat.Add key1, 1
    End If
    If Not dictMat.Exists(key2) Then
        dictMat(key2) = dictMat(key2) + 1
    End If
Next

For Each key In dictMat
    Loc = Split(key)(0)
    Mat = Split(key)(1)
    If SheetExist(wb2, Loc) Then
        Set ws2 = wb2.Sheets(Loc)
        Set rngMat = ws2.Range("G41", "G53")
        With ws2
            If Mat Like "N#" Or Mat Like "N##" Then
                .Range("H34") = .Range("H34") + dictMat(key)
            Else
                Add = GetAdd(Mat, rngMat)
                .Range(Add) = dictMat(key)
            End If
        End With
    Else
        wb2.Sheets.Add.Name = Loc
        Set ws2 = wb2.Sheets(Loc)
        wsTmp.Cells.Copy ws2.Range("A1")
        Set rngMat = ws2.Range("G41", "G53")
        ws2.Range("K6") = Loc
        With ws2
            If Mat Like "N#" Or Mat Like "N##" Then
                .Range("H34") = .Range("H34") + dictMat(key)
            Else
                Add = GetAdd(Mat, rngMat)
                .Range(Add) = dictMat(key)
            End If
        End With
    End If
Next
SortSheetsTabs wb2
wb2.Sheets("Sheet1").Delete

End Sub

Function SheetExist(wb As Workbook, Loc As String) As Boolean

Dim n As Long, nLoc As Long, nSht As Long, nMin As Long
Dim ws As Worksheet

For Each ws In wb.Sheets
    If ws.Name = Loc Then
        SheetExist = True
    End If
Next

End Function

Sub SortSheetsTabs(wb As Workbook)

Dim nSht As Long, i As Long, j As Long

nSht = Sheets.Count
For i = 1 To nSht - 1
    For j = i + 1 To nSht
        If UCase(Sheets(j).Name) < UCase(Sheets(i).Name) Then
            Sheets(j).Move Before:=Sheets(i)
        End If
    Next j
Next i

Application.ScreenUpdating = True
End Sub

Function GetAdd(ByVal Mat As String, ByRef rng As Range) As String

Dim rngFound As Range

Set rngFound = rng.Find(Mat, LookAt:=xlWhole)
If Not rngFound Is Nothing Then
    GetAdd = rngFound.Offset(0, 1).Address(0, 0)
End If

End Function

Function NewWorkbook(wbPath As String, wbName As String, wsCount As Long) As Workbook
' creates a new workbook with wsCount (1 to 255) worksheets
Dim OriginalWorksheetCount&
Dim NewName$

Set NewWorkbook = Nothing
If wsCount < 1 Or wsCount > 255 Then Exit Function
OriginalWorksheetCount = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = wsCount
Set NewWorkbook = Workbooks.Add
NewName = wbPath & wbName
ActiveWorkbook.SaveAs NewName
Application.SheetsInNewWorkbook = OriginalWorksheetCount

End Function
 

karen02

New Member
Joined
Sep 15, 2021
Messages
15
Office Version
  1. 2019
Platform
  1. Windows
This is how new macro works.

The macro is in wb1 with Sheet1 having list of data to compile. In wb1 also you will have another sheet called Template where you will have the template you showed me.
Location at K6
Node at H14
Material1 to Material13 from H41 to H53

You can list the Material in any order and the program will put the Qty next to corresponding Material.

Once the program run, a wb2 (you can name it as you like. See remark in macro) is created and sheets will be created when needed with a copy of Template from wb1. I hope this works flawlessly.
VBA Code:
Sub Summarize()

Dim key1 As String, key2 As String, Add As String
Dim Loc As String, wb2Name As String
Dim nRow As Long
Dim key As Variant
Dim cell As Range, rngFound As Range
Dim rngLoc As Range, rngMat As Range
Dim ws1 As Worksheet, ws2 As Worksheet, wsTmp As Worksheet
Dim wb1 As Workbook, wb2 As Workbook
Dim dictMat As Object, dictN As Object

Set dictMat = CreateObject("Scripting.Dictionary")
Set wb1 = ActiveWorkbook
Set ws1 = wb1.Sheets("Sheet1")
Set wsTmp = wb1.Sheets("Template")

Application.ScreenUpdating = False

' Set wb2 name here
wb2Name = "WB2"

Set wb2 = NewWorkbook(wb1.Path & "\", wb2Name, 1)
Set rngLoc = ws1.Range("A2", ws1.Cells(Rows.Count, "A").End(xlUp))

dictMat.RemoveAll
For Each cell In rngLoc
    key1 = cell.Value & " " & cell.Offset(, 1).Value
    key2 = cell.Value & " " & cell.Offset(, 2).Value
    If dictMat.Exists(key1) Then
        dictMat(key1) = dictMat(key1) + 1
    Else
        dictMat.Add key1, 1
    End If
    If Not dictMat.Exists(key2) Then
        dictMat(key2) = dictMat(key2) + 1
    End If
Next

For Each key In dictMat
    Loc = Split(key)(0)
    Mat = Split(key)(1)
    If SheetExist(wb2, Loc) Then
        Set ws2 = wb2.Sheets(Loc)
        Set rngMat = ws2.Range("G41", "G53")
        With ws2
            If Mat Like "N#" Or Mat Like "N##" Then
                .Range("H34") = .Range("H34") + dictMat(key)
            Else
                Add = GetAdd(Mat, rngMat)
                .Range(Add) = dictMat(key)
            End If
        End With
    Else
        wb2.Sheets.Add.Name = Loc
        Set ws2 = wb2.Sheets(Loc)
        wsTmp.Cells.Copy ws2.Range("A1")
        Set rngMat = ws2.Range("G41", "G53")
        ws2.Range("K6") = Loc
        With ws2
            If Mat Like "N#" Or Mat Like "N##" Then
                .Range("H34") = .Range("H34") + dictMat(key)
            Else
                Add = GetAdd(Mat, rngMat)
                .Range(Add) = dictMat(key)
            End If
        End With
    End If
Next
SortSheetsTabs wb2
wb2.Sheets("Sheet1").Delete

End Sub

Function SheetExist(wb As Workbook, Loc As String) As Boolean

Dim n As Long, nLoc As Long, nSht As Long, nMin As Long
Dim ws As Worksheet

For Each ws In wb.Sheets
    If ws.Name = Loc Then
        SheetExist = True
    End If
Next

End Function

Sub SortSheetsTabs(wb As Workbook)

Dim nSht As Long, i As Long, j As Long

nSht = Sheets.Count
For i = 1 To nSht - 1
    For j = i + 1 To nSht
        If UCase(Sheets(j).Name) < UCase(Sheets(i).Name) Then
            Sheets(j).Move Before:=Sheets(i)
        End If
    Next j
Next i

Application.ScreenUpdating = True
End Sub

Function GetAdd(ByVal Mat As String, ByRef rng As Range) As String

Dim rngFound As Range

Set rngFound = rng.Find(Mat, LookAt:=xlWhole)
If Not rngFound Is Nothing Then
    GetAdd = rngFound.Offset(0, 1).Address(0, 0)
End If

End Function

Function NewWorkbook(wbPath As String, wbName As String, wsCount As Long) As Workbook
' creates a new workbook with wsCount (1 to 255) worksheets
Dim OriginalWorksheetCount&
Dim NewName$

Set NewWorkbook = Nothing
If wsCount < 1 Or wsCount > 255 Then Exit Function
OriginalWorksheetCount = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = wsCount
Set NewWorkbook = Workbooks.Add
NewName = wbPath & wbName
ActiveWorkbook.SaveAs NewName
Application.SheetsInNewWorkbook = OriginalWorksheetCount

End Function
Hi Zot, Thank you so much!!!
I have tried it and got an error regarding the range. How should I modify it?
I have followed what you have mentioned in wb1 - to add Template sheet.
Node is in H34 - same as what was written in the code.
I really appreciate your help!!! 😭 😭 😭
 

Attachments

  • Range error1.JPG
    Range error1.JPG
    25.5 KB · Views: 6
  • Range error2.JPG
    Range error2.JPG
    25.7 KB · Views: 6
  • WB1.JPG
    WB1.JPG
    107.2 KB · Views: 5
Last edited:

karen02

New Member
Joined
Sep 15, 2021
Messages
15
Office Version
  1. 2019
Platform
  1. Windows

ADVERTISEMENT

Hi Zot, Thank you so much!!!
I have tried it and got an error regarding the range. How should I modify it?
I have followed what you have mentioned in wb1 - to add Template sheet.
Node is in H34 - same as what was written in the code.
I really appreciate your help!!! 😭 😭 😭
I have tried to modify the code from G41, G53 to H41, H53 but same error.
Thank you!!!
 

Attachments

  • VBA Code.JPG
    VBA Code.JPG
    50.5 KB · Views: 4

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
2,005
Office Version
  1. 2016
Platform
  1. Windows
It could not be. I have tested it and run without any problem

Is the template exactly like the one you provided? What is the range of your Material?

From your example
WB2.xlsx
FGH
39
40
41Material1
42Material2
43Material3
44Material4
45Material5
46Material6
47Pump1
48Valve
49Tx3
50Material10
51Material11
52Material12
53Material13
54
55
56
L2
 

karen02

New Member
Joined
Sep 15, 2021
Messages
15
Office Version
  1. 2019
Platform
  1. Windows

ADVERTISEMENT

It could not be. I have tested it and run without any problem

Is the template exactly like the one you provided? What is the range of your Material?

From your example
WB2.xlsx
FGH
39
40
41Material1
42Material2
43Material3
44Material4
45Material5
46Material6
47Pump1
48Valve
49Tx3
50Material10
51Material11
52Material12
53Material13
54
55
56
L2
Hi Zot, Yes it was the same as earlier. But I think I need to change from G to B. Correct?
 

Attachments

  • WB1_Template.JPG
    WB1_Template.JPG
    116.9 KB · Views: 5
  • WB1_Sheet1.JPG
    WB1_Sheet1.JPG
    106.1 KB · Views: 5

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
2,005
Office Version
  1. 2016
Platform
  1. Windows
Hi Zot, Yes it is the same.
Nope. It is not the same. The macro looks for matching material name in column G41 to G53 (not the column H) and give the address 1 column to the right.

Now your range is B41 to B46 and you need to fill Qty in column H. I need to change the code a bit
 

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
2,005
Office Version
  1. 2016
Platform
  1. Windows
Try this
VBA Code:
Sub Summarize()

Dim key1 As String, key2 As String, Add As String
Dim Loc As String, wb2Name As String
Dim nRow As Long
Dim key As Variant
Dim cell As Range, rngFound As Range
Dim rngLoc As Range, rngMat As Range
Dim ws1 As Worksheet, ws2 As Worksheet, wsTmp As Worksheet
Dim wb1 As Workbook, wb2 As Workbook
Dim dictMat As Object, dictN As Object

Set dictMat = CreateObject("Scripting.Dictionary")
Set wb1 = ActiveWorkbook
Set ws1 = wb1.Sheets("Sheet1")
Set wsTmp = wb1.Sheets("Template")

Application.ScreenUpdating = False

' Set wb2 name here
wb2Name = "WB2"

Set wb2 = NewWorkbook(wb1.Path & "\", wb2Name, 1)
Set rngLoc = ws1.Range("A2", ws1.Cells(Rows.Count, "A").End(xlUp))

dictMat.RemoveAll
For Each cell In rngLoc
    key1 = cell.Value & " " & cell.Offset(, 1).Value
    key2 = cell.Value & " " & cell.Offset(, 2).Value
    If dictMat.Exists(key1) Then
        dictMat(key1) = dictMat(key1) + 1
    Else
        dictMat.Add key1, 1
    End If
    If Not dictMat.Exists(key2) Then
        dictMat(key2) = dictMat(key2) + 1
    End If
Next

For Each key In dictMat
    Loc = Split(key)(0)
    Mat = Split(key)(1)
    If SheetExist(wb2, Loc) Then
        Set ws2 = wb2.Sheets(Loc)
        Set rngMat = ws2.Range("B41", "B53")
        With ws2
            If Mat Like "N#" Or Mat Like "N##" Then
                .Range("H34") = .Range("H34") + dictMat(key)
            Else
                Add = GetAdd(Mat, rngMat)
                .Range(Add) = dictMat(key)
            End If
        End With
    Else
        wb2.Sheets.Add.Name = Loc
        Set ws2 = wb2.Sheets(Loc)
        wsTmp.Cells.Copy ws2.Range("A1")
        Set rngMat = ws2.Range("GB1", "B53")
        ws2.Range("K6") = Loc
        With ws2
            If Mat Like "N#" Or Mat Like "N##" Then
                .Range("H34") = .Range("H34") + dictMat(key)
            Else
                Add = GetAdd(Mat, rngMat)
                .Range(Add) = dictMat(key)
            End If
        End With
    End If
Next
SortSheetsTabs wb2
wb2.Sheets("Sheet1").Delete

End Sub

Function SheetExist(wb As Workbook, Loc As String) As Boolean

Dim n As Long, nLoc As Long, nSht As Long, nMin As Long
Dim ws As Worksheet

For Each ws In wb.Sheets
    If ws.Name = Loc Then
        SheetExist = True
    End If
Next

End Function

Sub SortSheetsTabs(wb As Workbook)

Dim nSht As Long, i As Long, j As Long

nSht = Sheets.Count
For i = 1 To nSht - 1
    For j = i + 1 To nSht
        If UCase(Sheets(j).Name) < UCase(Sheets(i).Name) Then
            Sheets(j).Move Before:=Sheets(i)
        End If
    Next j
Next i

Application.ScreenUpdating = True
End Sub

Function GetAdd(ByVal Mat As String, ByRef rng As Range) As String

Dim rngFound As Range

Set rngFound = rng.Find(Mat, LookAt:=xlWhole)
If Not rngFound Is Nothing Then
    GetAdd = rngFound.Offset(0, 6).Address(0, 0)
End If

End Function

Function NewWorkbook(wbPath As String, wbName As String, wsCount As Long) As Workbook
' creates a new workbook with wsCount (1 to 255) worksheets
Dim OriginalWorksheetCount&
Dim NewName$

Set NewWorkbook = Nothing
If wsCount < 1 Or wsCount > 255 Then Exit Function
OriginalWorksheetCount = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = wsCount
Set NewWorkbook = Workbooks.Add
NewName = wbPath & wbName
ActiveWorkbook.SaveAs NewName
Application.SheetsInNewWorkbook = OriginalWorksheetCount

End Function
 

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
2,005
Office Version
  1. 2016
Platform
  1. Windows
Noticed that I change the range from column G to B
The address is in Function GetAdd. The offset value change from 1 to 6. Last time from G to H shift 1 column to right, Now from G shift 6 column to right
Rich (BB code):
Function GetAdd(ByVal Mat As String, ByRef rng As Range) As String

Dim rngFound As Range

Set rngFound = rng.Find(Mat, LookAt:=xlWhole)
If Not rngFound Is Nothing Then
    GetAdd = rngFound.Offset(0, 6).Address(0, 0)
End If

End Function
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,151,856
Messages
5,766,786
Members
425,378
Latest member
kapoor2892

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
Top