VBA code to get data from one workbook to another

K

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.
 
Sort by date Sort by votes
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
 
Upvote 0

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Zot said:
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
Click to expand...
Still same error on my side :( :(
It works on you?
 

Attachments

  • Code.JPG
    Code.JPG
    57.6 KB · Views: 6
Upvote 0
Zot said:
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
Click to expand...
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: 11
Upvote 0
Check if you copy the latest code. Check the range was wrong in previous one. I tested ok already
 
Upvote 0
Zot said:
Check if you copy the latest code. Check the range was wrong in previous one. I tested ok already
Click to expand...
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: 10
Last edited:
Upvote 0
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
 
Upvote 0
Zot said:
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
Click to expand...
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.:)
 
Upvote 0
karen02 said:
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.:)
Click to expand...
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.
 
Upvote 0
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.
 
Upvote 0
Zot said:
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.
Click to expand...
Hi Zot,
It works now. Thank you so much!!
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
modifying code to get last value based on sheet name from file to another
Replies
7
Views
176
mumps
mumps
N
  • Question
VBA - Copying specific data to open workbook.
Replies
1
Views
292
eiloken
E
S
  • Question
Copy listobject table from one worksheet to another workbook
Replies
2
Views
873
Alex Blakenburg
A
A
  • Question
Find value from one workbook in another
Replies
4
Views
234
AndyEd
A
D
  • Question
VBA function (i.e., Sum expenditures over multiple worksheets in one workbook into another workbook)
Replies
1
Views
470
sijpie
sijpie

Forum statistics

Threads
1,214,391
Messages
6,119,249
Members
448,879
Latest member
oksanana

Share this page

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
Back
Top