Loop Through Column & Match Data With Column in Another Worksheet using VBA

jewkes6000

Board Regular
Joined
Mar 25, 2020
Messages
60
Office Version
  1. 365
Platform
  1. Windows
This one is a doosey, but I thought I'd still give it a try. I am trying to run a macro which takes data from my "Database" tab and imports it into my "Tool" tab by matching the data from columns in each tab. Here is what I need to happen:
  • Loop through column B on the "Tool" tab
  • For each row it loops through in the "Tool" tab, it needs to check the value in column B, and see if there is a match in column E in the "Database" tab
  • At the same time, it needs to check if the project name matches. The project name on the "Tool" tab is located in cell C1. The project name for each line item on the "Database" tab is located in column A.
  • If the project name matches the "Database" column A AND the Cost Code Description matches the "Database" column E, then I need to copy the data for that row in the "Database" tab columns F through I into the "Tool" tab under columns C through F.
For example, if my project name was "Project 4.0", and I was on row 82 in the "Tool" tab (Structural Steel), then it would copy the following numbers into columns C through F. These numbers come from row 57 on the "Database" tab.
  • Column C = 63,159
  • Column D = 86,843
  • Column E = 7,895
  • Column F = 157,897

Last, to throw a wrench into things, if there are multiple matches on the "Database" tab, I need to add them together. For example, if my project name was "Project 3", and I was on row 249 in the "Tool" tab (Electrical), then it would copy the following numbers into columns C through F (Only bold numbers to copy, just showing the other numbers for clarification). These numbers come from rows 155, 199, 232 & 253 on the "Database" tab.
  • Column C = 821,165+37,418+223,677+52,060 = 1,134,320
  • Column D = 1,129,102+51,450+307,556+71,582 = 1,559,690
  • Column E = 102,646+4,677+27,960+6,507 = 141,790
  • Column F = 2,052,912+93,546+559,192+130,149 = 2,835,799

Here is a link to download the sample file:

I know this one is complicated and hard to follow, but any help is greatly appreciated. I've been stuck on this one for a few days now. Thank you in advance!
 

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
How about
VBA Code:
Sub jeweks()
   Dim Tary As Variant, Dary As Variant
   Dim r As Long, nr As Long
   Dim Cl As Range
   Dim Project As String
   
   With Sheets("Tool")
      Project = .Range("C1").Value
      Tary = .Range("B7:F" & .Range("B" & Rows.Count).End(xlUp).Row).Value2
   End With
   Dary = Sheets("Database").Range("A1").CurrentRegion.Value2
      
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Tary)
         If Tary(r, 1) <> "" Then .Item(Tary(r, 1)) = r
      Next r
      For r = 2 To UBound(Dary)
         If Dary(r, 1) = Project Then
            If .Exists(Dary(r, 5)) Then
               nr = .Item(Dary(r, 5))
               Tary(nr, 2) = Tary(nr, 2) + Dary(r, 6)
               Tary(nr, 3) = Tary(nr, 3) + Dary(r, 7)
               Tary(nr, 4) = Tary(nr, 4) + Dary(r, 8)
               Tary(nr, 5) = Tary(nr, 5) + Dary(r, 9)
            End If
         End If
      Next r
      Sheets("Tool").Range("B7").Resize(UBound(Tary), 5).Value = Tary
   End With
End Sub
 
Upvote 0
@Fluff - Thank you for this. I've been trying to digest and understand this for the better part of the day. Your methods are more advanced that what I am used to working with in VBA and I haven't been able to figure out how to make adjustments. If you don't mind, could you please provide some comments in your code explaining what's happening? I'm specifically referring to the line which says "For r=2 To Ubound(Dary) and then all of the lines below that. That is where I got lost.

I've also included a link to my updated file as there is more data I need to import. I thought I could make it more simple then take the concepts and apply them, but obviously I got lost. So here is a more complete look at what I'm trying to do:
  • Import multiple projects on the "Tool" tab. So after importing Project 3, I would like to import Project 1 right next to it.
  • Further, there are more columns I need to import ("Scope Qty", "Unit of Measure", "Scope Unit Cost", etc.)
I apologize for trying to make it more simple and not including everything, but again, I can typically figure out the code and apply it to my needs.

Here is the updated file:

 
Upvote 0
How about
VBA Code:
Sub jeweks()
   Dim Tary As Variant, Dary As Variant
   Dim r As Long, nr As Long, x As Long, c As Long
   Dim Cl As Range
   Dim Project(1 To 3) As String
   
   With Sheets("Tool")
      Project(1) = .Range("C1").Value
      Project(2) = .Range("M1").Value
      Project(3) = .Range("W1").Value
      Tary = .Range("B7:AE" & .Range("B" & Rows.Count).End(xlUp).Row).Value2
   End With
   Dary = Sheets("Database").Range("A1").CurrentRegion.Value2
      
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Tary)
         If Tary(r, 1) <> "" Then .Item(Tary(r, 1)) = r
      Next r
      For r = 2 To UBound(Dary)
         If Dary(r, 1) = Project(1) Then x = 2
         If Dary(r, 1) = Project(2) Then x = 12
         If Dary(r, 1) = Project(3) Then x = 22
         If x <> 0 Then
            If .Exists(Dary(r, 5)) Then
               nr = .Item(Dary(r, 5))
               For c = 0 To 8
                  Tary(nr, x + c) = Tary(nr, x + c) + Dary(r, c + 6)
               Next c
            End If
         End If
         x = 0
      Next r
      Sheets("Tool").Range("B7").Resize(UBound(Tary), UBound(Tary, 2)).Value = Tary
   End With
End Sub
 
Upvote 0
@Fluff
I am still running into issues making this work. On my main spreadsheet, under the "Tool" tab, I have several formulas adding up subtotals. I do not want these formulas to get erased. When the code copies everything into the "Tool" tab, it puts zeros in the blank cells. Also, if it makes it easier, in column "E", I only need rows which contain "Single" to get populated.

The attached spreadsheet is the complete spreadsheet. Again, I tried making it work and you can look at my code to see my changes, but I can't get it to work. This one has been KILLING ME!

Once again thank you! I've already learned so much new stuff.

 
Upvote 0
That is a totally different situation to your initial question & will require a different approach, partly due to the fact that you have formulae & preset values in the tool sheet.
Simplifying your problem in the hope of getting help is a bad idea, because you just end up with something that doesn't work.

Unfortunately I do not have the time to assist any further, as this is now more of a project, than a bit of help.
 
Upvote 0
@Fluff - I totally understand. Thank you for your help. I was able to find a solution on my own; however, it's much much slower than using the dictionary in your code. Wish I know how to make it work. Either way, this code works for this situation. You would still need to repeat for each project; however, I didn't want to make this post that long.

VBA Code:
Sub Compare_Projects()
Dim r As Long, nr As Long, x As Long, c As Long, LastRowTool As Long, LastRowDB As Long, CurrentCostCod As Long
Dim SearchRangeTool As Range
Dim Project1 As String, Project2 As String, Project3 As String, Project4 As String, Project5 As String, Project6 As String, Project7 As String, Project8 As String
 
Application.ScreenUpdating = False

On Error Resume Next
Sheets("Compare Tool").ShowAllData
Sheets("Cost Data").ShowAllData
Sheets("Compare Tool").Range("Clear_Cells").SpecialCells(xlConstants).ClearContents
Sheets("Compare Tool").Range("AD19,AQ19,BD19,BQ19,CD19,CQ19,DD19,DQ19").ClearContents
On Error GoTo 0

   With Sheets("Setup Page")
       Project1 = .Range("U11").Value
       Project2 = .Range("U12").Value
       Project3 = .Range("U13").Value
       Project4 = .Range("U14").Value
       Project5 = .Range("U15").Value
       Project6 = .Range("U16").Value
       Project7 = .Range("U17").Value
       Project8 = .Range("U18").Value
    End With

    'Set the last row on the Compare Tool worksheet
    With Sheets("Compare Tool")
        Set SearchRangeTool = .Range("E:E").Find(What:="Last Row")
        LastRowTool = SearchRangeTool.Row
    End With
   
    'Set the last row on the Cost Data worksheet
    With Sheets("Cost Data")
        LastRowDB = .Range("A1048576").End(xlUp).Row
    End With
   
    'Loop through rows on Compare Tool worksheet to find either "Single" or "T2 Head in column E
    Sheets("Compare Tool").Select
    If Project1 <> "" Then
        For r = 28 To LastRowTool
            If Cells(r, 5) = "Single" Or Cells(r, 5) = "T2 Head" Then
                CurrentCostCode = Cells(r, 21)
                CurrentT0 = Cells(r, 9)
                With Sheets("Cost Data")
                    For x = 2 To LastRowDB
                        If .Cells(x, 1) = Project1 And .Cells(x, 34) = CurrentCostCode And .Cells(x, 22) = CurrentT0 Then
                            .Range("AK" & x, "AQ" & x).Copy 'Putting a period means it refers to the "With statment"
                            Sheets("Compare Tool").Cells(r, 24).Select
                            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _
                                :=False, Transpose:=False
                            'This will check to see if the "Scope Qty" column is blank in the DB, and then copy if not blank
                            If .Range("AR" & x) <> "" Then
                                .Range("AR" & x).Copy
                                Sheets("Compare Tool").Cells(r, 31).Select
                                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _
                                :=False, Transpose:=False 'This will paste data into the scope qty column and add to whatever is there
                               
                                .Range("AS" & x).Copy
                                Sheets("Compare Tool").Cells(r, 32).Select
                                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False 'This will paste data into the UoM column and overwrite whatever is there
                            End If
                        Else
                        End If
                    Next x
                End With
            End If
        Next r
    End If

Application.ScreenUpdating = True
End Sub
 
Upvote 0
Solution
Glad you sorted it & thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,256
Members
448,557
Latest member
richa mishra

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