VBA code to get data from one workbook to another

[karen02]

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]

It would be helpful if you create sample for WB1 and expected WB2.

 

[karen02]

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!

 

[Zot]

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
	A	B	C
1	Location	Materials	Node
2	L5	Tx	N1
3	LI	Pump	N1
4	LI	Valve	N1
5	L2	Tx	N1
6	L3	Valve	N1
7	L2	Pump	N2
8	L2	Tx	N2
9	L4	Pump	N1
10	L4	Pump	N1
11	L3	Valve	N1
12	L4	Pump	N1
13	L4	Tx	N2
14	L4	Tx	N2
15	L4	Tx	N2
16	L5	Tx	N3
17	L5	Tx	N2
18	L5	Tx	N1
19	L3	Tx	N3
20	L2	Tx	N2
21	L3	Valve	N3
Sheet1

 

[karen02]

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]

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
	A	B	C
1	Location	Materials	Node
2	L5	Tx	N1
3	LI	Pump	N1
4	LI	Valve	N1
5	L2	Tx	N1
6	L3	Valve	N1
7	L2	Pump	N2
8	L2	Tx	N2
9	L4	Pump	N1
10	L4	Pump	N1
11	L3	Valve	N1
12	L4	Pump	N1
13	L4	Tx	N2
14	L4	Tx	N2
15	L4	Tx	N2
16	L5	Tx	N3
17	L5	Tx	N2
18	L5	Tx	N1
19	L3	Tx	N3
20	L2	Tx	N2
21	L3	Valve	N3
Sheet1

Thank you, Zot!!

 

[Zot]

Looks like no one replying. I was on leave due to public holiday yesterday ?. Try if this works

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]

Looks like no one replying. I was on leave due to public holiday yesterday ?. Try if this works

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

 

[Zot]

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]

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