Solved VB macro to merge to data set based on several conditions

March 22, 2017 at 06:44:52
Specs: Windows 64
Description: there are two worksheets, one of them is used as a file with the original data set (master data) and the second of which correspond to updates to the original data. The master file is the size in A1: L, where the first row stands for names. The update file data is in the range: A1: Q, where the first row again corresponds to the column names.

In column D of the update file there are items numbers (ID) which correspond to IDs in column G of the master File in unspecified order. In the column Q of the update file, there are three criteria: price, text, text and price. In column B of the update file, there are two criteria: delete and update.

Task Steps:
Step 1: The macro finds a match between the two: column D in the update file and column G in the main file.
Step 2: If there is match in step 1, the macro checks the column B value:
• if the cell contain is “delete”, then in column L of the main file in the corresponding to the found match cell, insert the date value (as defined in the variable: vDato).
• Step 3: If the cell contain is “update”, so go to the column Q of the update file and proceed based on:
 If the cell value is “text”, so do not do anything (exit)
 If the cell value is “price” or “text and price”, then add a row after the found matching items number and copy-paste the value of the price from the column O from the update worksheet to the cell in column I in the master sheet.

Challenge: Both files about 30.000 rows down, so the macro has to proceed via arrays. Anyway, I first to make my steps via ranges as it is more convenient for me. I defined ranges and worked with IF statements via looping, yet, the first macro runs slowly, but nothing is happening, while the second macro expectedly stops. Still, I would like to complete my macro first without array since I'd like to get understanding what I am doing wrong. I will appeciate any help as I am been working on different scenarios and cannot reach my goal.

Sub CopyPriceForEachDansk()

Dim lastID1 As Long, lastID2 As Long
Dim c As Range, ID As Range
Dim rMaster As Range
Dim rUpdate As Range
Dim rDeliteUpdate As Range
Dim criteria As Range
Dim Text As Range
Dim rTextPrice As Range
Dim N As Long
Dim vDato As Variant

lastID1 = Sheets("WsMaster").Range("G" & Rows.Count).End(xlUp).Row
lastID2 = Sheets("WbUpdate").Range("D" & Rows.Count).End(xlUp).Row

Set rMaster = Sheets("WsMaster").Range("G2:G" & lastID1)
Set rUpdate = Sheets("WbUpdate").Range("D2:D" & lastID2)

Set rDeliteUpdate = Sheets("WbUpdate").Range("B" & lastID2)
Set rTextPrice = Sheets("WbUpdate").Range("Q2:Q" & lastID2)

vDato = InputBox("Insert date of update", "Identificator")
If Len(vDato) = 0 Then Exit Sub

Application.ScreenUpdating = False

N = 1
   For Each ID In rMaster
     With rUpdate
        Set c = .Find(ID, lookat:=xlWhole)
         If Not c Is Nothing Then
          For Each criteria In rDeliteUpdate
            If criteria Like "delite" Then
             Sheets("WsMaster").Range("L" & criteria.Row) = vDato
                If criteria Like "update" Then
                 For Each Text In rTextPrice
                  If (Text Like "Price" Or "Text  and price") Then
                    Sheets("WbUpdate").Cells(Text.Row, 15).Copy .Cells(ID.Row, 15)
                  End If
                  N = N + 1
                 Next Text
                End If
             End If
          Next criteria
        End If
     End With
   Next ID

Application.ScreenUpdating = True

If N = 1 Then
MsgBox "No Match is found"
End If

  
End Sub

I had another macro through i and j looping there I could't understand how to add the row after the certain conditions are fulfilled.

Sub CopyDataBasedOnMultipleCriterias()

Dim WsMaster, WbUpdate, vDato As Variant
Dim i, j, k As Long
Dim wb1 As Workbook, wb2 As Workbook
 
'Dim wbMaster As Workbook Set wbMaster = ThisWorkbook.

WsMaster = Sheets("WsMaster").Range("A1:Q" & Sheets("WsMaster").Range("A1").CurrentRegion.Rows.Count)
WbUpdate = Sheets("WbUpdate").Range("A1:N" & Sheets("WbUpdate").Range("A1").CurrentRegion.Rows.Count)
   
vDato = InputBox("Insert date of update", "Identificator")
If Len(vDato) = 0 Then Exit Sub

Application.ScreenUpdating = False

' Loop through all items in Update, start with row 2
k = 1
    For i = 2 To UBound(WbUpdate)
        For j = 2 To UBound(WsMaster)
        ' Take the value in column D
        ' Look for a match in WsMaster.Column(G)
        'If there is a match Then
            If (WbUpdate(j, 4) = WsMaster(i, 7)) Then
            'If there is a match Then
                If (WbUpdate(i, 2) = "delete") Then
                ' If Update.Column(B) = "Delete"
                ' Let WsMaster.Column(L) = vDato
                    WsMaster(j, 12) = vDato
                    ' If Update.Column(B) is "Update"
                    If (WbUpdate(j, 2) = "update") Then
                     ' If Update.Column(Q) = "Price" Or "Text and price"
                            If (WbUpdate(i, 17) = "Price" Or "Text and Price") Then
                            ' Add row in WsMaster below matched row - here I am not aware af how I proceed with adding a row
                              Sheets("WsMaster").Range("A:Q" & Sheets("WsMaster").Range("A:Q").CurrentRegion.Rows.Count + 1) = WbUpdate(i, 15)
                              ' Copy price from WsUpdate.Column(O) to WsMaster.Column(I) in the new row
                               WsMaster.Range("I" & j.Row) = WbUpdate.Range("O" & i.Row).Offset(1, 0)
                              'If Update.Column(Q) = "Text"
                              
                              k = k + 1
                            End If
                    End If
                End If
            End If
        Next
    Next
  
Application.ScreenUpdating = True

' If there is no match Then
If k = 1 Then
MsgBox "No Match is found"
End If

        
End Sub



See More: VB macro to merge to data set based on several conditions

Report •

#1
March 23, 2017 at 02:06:27
✔ Best Answer
Hey,

Thanks for pointing out on the similar examples - I got a look at them, and tried to make some changes in my marco. Still, when I run my macro, it doesn't perform that is intentioned. Could anyone please suggest what the issue is? Thanks in advance.

Sub CopyPriceForEachMatch()

Dim lastID1 As Long, lastID2 As Long
Dim c As Range, ID As Range
Dim rMaster As Range
Dim rUpdate As Range
Dim rDeliteUpdate As Range
Dim criteria As Range
Dim Text As Range
Dim rTextPrice As Range
Dim N As Long
Dim vDato As Variant
Dim WsM As Worksheet
Dim WbU As Worksheet

Set WsM = Sheets("WsMaster")
Set WbU = Sheets("WbUpdate")
lastID1 = WsM.Range("G" & Rows.Count).End(xlUp).Row
lastID2 = WbU.Range("D" & Rows.Count).End(xlUp).Row
Set rMaster = WsM.Range("G2:G" & lastID1)
Set rUpdate = WbU.Range("D2:D" & lastID2)
Set rDeliteUpdate = WbU.Range("B" & lastID2)
Set rTextPrice = WbU.Range("Q2:Q" & lastID2)

vDato = InputBox("Insert date of update", "Identificator")
If Len(vDato) = 0 Then Exit Sub

Application.ScreenUpdating = False

N = 1
   For Each ID In rMaster
     With rUpdate
        Set c = .Find(ID, lookat:=xlWhole)
         If Not c Is Nothing Then
          For Each criteria In rDeliteUpdate
            If criteria Like "delite" Then
             WsM.Range("L" & criteria.Row) = vDato
              WsM.Range("L" & criteria.Row).Interior.ColorIndex = 19
                If criteria Like "update" Then
                 For Each Text In rTextPrice
                  If (Text Like "price" Or "Text og price") Then
                  WsM.Range("G" & ID.Offset(1, 0)).Rows.EntireRow.Insert
                   WbU.Range("O" & Text.Row).Copy WsM.Range("O" & ID.Row + 1)
                    WsM.Range("O" & ID.Row + 1).Interior.ColorIndex = 20
                  End If
                  N = N + 1
                 Next Text
                End If
             End If
          Next criteria
        End If
     End With
   Next ID

Application.ScreenUpdating = True

If N = 1 Then
MsgBox "No Match is found"
End If

  
End Sub



Report •
Related Solutions


Ask Question