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.
 

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
1,774
Office Version
  1. 2016
Platform
  1. Windows
It would be helpful if you create sample for WB1 and expected WB2.
 

karen02

New Member
Joined
Sep 15, 2021
Messages
15
Office Version
  1. 2019
Platform
  1. Windows
It would be helpful if you create sample for WB1 and expected WB2.
Hi Zot,

I have attached sample simplified version of WB1 and expected WB2 after running the code.
Thank you very much for your time and help!
 

Attachments

  • WB1.JPG
    WB1.JPG
    88.9 KB · Views: 14
  • WB1_L1 filtered.JPG
    WB1_L1 filtered.JPG
    42.1 KB · Views: 14
  • WB2.JPG
    WB2.JPG
    37.5 KB · Views: 14

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
1,774
Office Version
  1. 2016
Platform
  1. Windows
Much easier for helper to be able to copy and paste data than rewriting it. I have converted to sheet. This should be easy for those familiar with this kind of data. I'm still figuring out the best way 😅
aaa.xlsx
ABC
1LocationMaterialsNode
2L5TxN1
3LIPumpN1
4LIValveN1
5L2TxN1
6L3ValveN1
7L2PumpN2
8L2TxN2
9L4PumpN1
10L4PumpN1
11L3ValveN1
12L4PumpN1
13L4TxN2
14L4TxN2
15L4TxN2
16L5TxN3
17L5TxN2
18L5TxN1
19L3TxN3
20L2TxN2
21L3ValveN3
Sheet1
 

karen02

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

ADVERTISEMENT

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.
Hi guyss, looking for help :(
 

karen02

New Member
Joined
Sep 15, 2021
Messages
15
Office Version
  1. 2019
Platform
  1. Windows
Much easier for helper to be able to copy and paste data than rewriting it. I have converted to sheet. This should be easy for those familiar with this kind of data. I'm still figuring out the best way 😅
aaa.xlsx
ABC
1LocationMaterialsNode
2L5TxN1
3LIPumpN1
4LIValveN1
5L2TxN1
6L3ValveN1
7L2PumpN2
8L2TxN2
9L4PumpN1
10L4PumpN1
11L3ValveN1
12L4PumpN1
13L4TxN2
14L4TxN2
15L4TxN2
16L5TxN3
17L5TxN2
18L5TxN1
19L3TxN3
20L2TxN2
21L3ValveN3
Sheet1
Thank you, Zot!!
 

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
1,774
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

Looks like no one replying. I was on leave due to public holiday yesterday 😁. Try if this works
VBA Code:
Sub Summarize()

Dim key1 As String, key2 As String
Dim Loc As String, Mat As String
Dim nRow As Long
Dim key As Variant
Dim cell As Range, rngLoc As Range
Dim ws1 As Worksheet, ws2 As Worksheet
Dim wb1 As Workbook, wb2 As Workbook
Dim dictMat As Object, dictN As Object

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

Workbooks.Add.SaveAs Filename:=wb1.Path & "\" & "WB2"
Set wb2 = ActiveWorkbook

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)
        With ws2
            If Left(Mat, 1) = "N" Then
                .Range("B2") = .Range("B2") + dictMat(key)
            Else
                nRow = .Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
                .Range("A" & nRow) = Mat
                .Range("B" & nRow) = dictMat(key)
            End If
        End With
    Else
        wb2.Sheets.Add(After:=wb2.Sheets(wb2.Sheets.Count)).Name = Loc
        Set ws2 = wb2.Sheets(Loc)
        With ws2
            If .Range("A1") = "" Then .Range("A1") = Loc
            .Range("A2") = "Node"
            .Range("B1") = "Qty"
            If Left(Mat, 1) = "N" Then
                .Range("B2") = .Range("B2") + dictMat(key)
            Else
                nRow = .Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
                .Range("A" & nRow) = Mat
                .Range("B" & nRow) = dictMat(key)
            End If
        End With
    End If
Next
SortSheetsTabs wb2

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
 

karen02

New Member
Joined
Sep 15, 2021
Messages
15
Office Version
  1. 2019
Platform
  1. Windows
Looks like no one replying. I was on leave due to public holiday yesterday 😁. Try if this works
VBA Code:
Sub Summarize()

Dim key1 As String, key2 As String
Dim Loc As String, Mat As String
Dim nRow As Long
Dim key As Variant
Dim cell As Range, rngLoc As Range
Dim ws1 As Worksheet, ws2 As Worksheet
Dim wb1 As Workbook, wb2 As Workbook
Dim dictMat As Object, dictN As Object

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

Workbooks.Add.SaveAs Filename:=wb1.Path & "\" & "WB2"
Set wb2 = ActiveWorkbook

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)
        With ws2
            If Left(Mat, 1) = "N" Then
                .Range("B2") = .Range("B2") + dictMat(key)
            Else
                nRow = .Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
                .Range("A" & nRow) = Mat
                .Range("B" & nRow) = dictMat(key)
            End If
        End With
    Else
        wb2.Sheets.Add(After:=wb2.Sheets(wb2.Sheets.Count)).Name = Loc
        Set ws2 = wb2.Sheets(Loc)
        With ws2
            If .Range("A1") = "" Then .Range("A1") = Loc
            .Range("A2") = "Node"
            .Range("B1") = "Qty"
            If Left(Mat, 1) = "N" Then
                .Range("B2") = .Range("B2") + dictMat(key)
            Else
                nRow = .Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
                .Range("A" & nRow) = Mat
                .Range("B" & nRow) = dictMat(key)
            End If
        End With
    End If
Next
SortSheetsTabs wb2

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
Woooww it works.. Thank you so much Zot, you are my hero. I really appreciate your help!! I am so happy that I want to cry :cry:🤣. I think I need some more help, sorry for that 🤣 There are other data in wb2 apart from the count that I want to take from wb1. Like it will be same template for all sheets in wb2 so the Node, Pump, Valve and Tx will be in same order in every sheet and if lets say pump is not existing in one location, then the cell will be blank or no qty shown. How to modify the code to incorporate the template? Sorry 😭 and thank you so much!!!!
 

Attachments

  • WB2.JPG
    WB2.JPG
    40.6 KB · Views: 7

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
1,774
Office Version
  1. 2016
Platform
  1. Windows
I just noticed that I've had line below twice. You can remove one.
Set dictMat = CreateObject("Scripting.Dictionary")

By the way, not really sure I understood. I think my code did not put the Material in order. It will be first come first serve, right? If you want to follow template, then need to modify a bit.

You mentioned wb2. You want to run the code in wb2 or copy everything to wb1, running from wb1?. How your template looks like? I have no idea how many Material items you'd have.
 

karen02

New Member
Joined
Sep 15, 2021
Messages
15
Office Version
  1. 2019
Platform
  1. Windows
I just noticed that I've had line below twice. You can remove one.
Set dictMat = CreateObject("Scripting.Dictionary")

By the way, not really sure I understood. I think my code did not put the Material in order. It will be first come first serve, right? If you want to follow template, then need to modify a bit.

You mentioned wb2. You want to run the code in wb2 or copy everything to wb1, running from wb1?. How your template looks like? I have no idea how many Material items you'd have.
Hi Zot, thanks for replying.

I will run the code in wb1 and wb2 will be the automatic output after running the code in wb1. What you have done is already correct :):)
Just need to follow template for wb2 to be the same for all. I have attached the sample template.
I have highlighted in yellow where the the data from wb1 will be located in wb2 template but there are a lot of materials and I just thought to give you some of it and I will just modify the code to add in others.
Sorry also if my explanation is not too clear :(
Thank you very much!!! :):):)
 

Attachments

  • WB2.JPG
    WB2.JPG
    159.4 KB · Views: 8

Forum statistics

Threads
1,144,422
Messages
5,724,227
Members
422,543
Latest member
Bravo661

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