VBA code to get data from one workbook to another

karen02 · Sep 15, 2021

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 · Sep 17, 2021

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.

karen02 · Sep 18, 2021

Zot said:
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

.
Thank you so much for you efforts!! Appreciated!!

Zot · Sep 19, 2021

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 · Sep 20, 2021

Zot said:

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!!! ? ? ?

karen02 · Sep 20, 2021

karen02 said:
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!!!

Zot · Sep 20, 2021

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

F

G

H

39

40

41

Material1

42

Material2

43

Material3

44

Material4

45

Material5

46

Material6

47

Pump

1

48

Valve

49

Tx

3

50

Material10

51

Material11

52

Material12

53

Material13

54

55

56

L2

karen02 · Sep 20, 2021

Zot said:
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
F G H
39
40
41 Material1
42 Material2
43 Material3
44 Material4
45 Material5
46 Material6
47 Pump 1
48 Valve
49 Tx 3
50 Material10
51 Material11
52 Material12
53 Material13
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?

Zot · Sep 20, 2021

karen02 said:
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 · Sep 20, 2021

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 · Sep 20, 2021

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

VBA code to get data from one workbook to another

karen02

New Member

Zot

Well-known Member

Excel Facts

karen02

New Member

Zot

Well-known Member

karen02

New Member

Attachments

karen02

New Member

Attachments

Zot

Well-known Member

karen02

New Member

Attachments

Zot

Well-known Member

Zot

Well-known Member

Zot

Well-known Member

Similar threads

Forum statistics

Share this page

VBA code to get data from one workbook to another

New Member

Well-known Member

Excel Facts

New Member

Well-known Member

New Member

Attachments

New Member

Attachments

Well-known Member

New Member

Attachments

Well-known Member

Well-known Member

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock