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
Opss typo error ... use 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("B41", "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
 

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.

karen02

New Member
Joined
Sep 15, 2021
Messages
15
Office Version
  1. 2019
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
Still same error on my side :( :(
It works on you?
 

Attachments

  • Code.JPG
    Code.JPG
    57.6 KB · Views: 1

karen02

New Member
Joined
Sep 15, 2021
Messages
15
Office Version
  1. 2019
Platform
  1. Windows
Opss typo error ... use 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("B41", "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
Now the error I think is almost on the last part. I can feel we are getting there :):)
Thank you!!!
 

Attachments

  • Code.JPG
    Code.JPG
    76.9 KB · Views: 4

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
2,005
Office Version
  1. 2016
Platform
  1. Windows
Check if you copy the latest code. Check the range was wrong in previous one. I tested ok already
 

karen02

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

ADVERTISEMENT

Check if you copy the latest code. Check the range was wrong in previous one. I tested ok already
I used the last code you sent. I dont know why it doesn't work on my side :(

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("B41", "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
 

Attachments

  • WB1.JPG
    WB1.JPG
    89.8 KB · Views: 5
Last edited:

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
2,005
Office Version
  1. 2016
Platform
  1. Windows
Is it possible for you to upload your sample file so that I can have a look the file. I have no problem with my mock up sample here
 

karen02

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

ADVERTISEMENT

Is it possible for you to upload your sample file so that I can have a look the file. I have no problem with my mock up sample here
Can I send to your email address? Thanks.

Or you can also send your files to me too then I will try to run it.:)
 

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
2,005
Office Version
  1. 2016
Platform
  1. Windows
Can I send to your email address? Thanks.

Or you can also send your files to me too then I will try to run it.:)
I only suspected that the range of the material name is not in column B from row 41 to 53. That is the only possible cause. Anyway, I have already sent you the e-mail address. You can use drop box to send file too.
 

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
2,005
Office Version
  1. 2016
Platform
  1. Windows
The problem is that the you are using merged cell for on Material list.

Not sure why but the file you sent crashed when I tried to save it. I have to delete Template and recreate another file and copy the template again to make it work. Not sure why.

Try Unmerged the cell B41 to B53. It should work. I did not know this can cause problem which I remember was not. Anyway, try avoid merged cell when dealing with macro. Many unexpected problem.
 

karen02

New Member
Joined
Sep 15, 2021
Messages
15
Office Version
  1. 2019
Platform
  1. Windows
The problem is that the you are using merged cell for on Material list.

Not sure why but the file you sent crashed when I tried to save it. I have to delete Template and recreate another file and copy the template again to make it work. Not sure why.

Try Unmerged the cell B41 to B53. It should work. I did not know this can cause problem which I remember was not. Anyway, try avoid merged cell when dealing with macro. Many unexpected problem.
Hi Zot,
It works now. Thank you so much!!
 
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,863
Messages
5,766,821
Members
425,379
Latest member
thedoctor00

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