PDA

View Full Version : Sleeper: Loop & Match to copy multiple row of data



Goala
06-07-2013, 07:08 AM
Hi Community,

i am trying to copy some of the information from an external source into a project inventory.

For that, I need to compare if the project name already exists in the inventory (--> update information) or not (--> use next free line to enter the information).

So far so good, this works quite well for the first row of the external data, but then my coding runs into an error.

"Run time error 1004" unable to get the match property of the worksheet function class.

I do not know what to do as I am fearly new to VBA and tried for multiple hours with other snips of codes from other VBA sheets in the company.

It would be great if someone could help me.

The VBA Code is below, when entering into the debug mode after the error message, the line "pRow" is marked in yellow.


Sub Import_Genius_Data()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim pRow As Integer
Dim iReply As Integer
Dim pReply As Integer
Dim pl As String
Dim plr As Range
Dim plg As Range
Dim xlg As Range
Dim xlr As Range
Set xlg = ActiveWorkbook.Sheets("Genius Data").Range("Genius_Import")
Set xlr = ActiveWorkbook.Sheets("Inventory").Range("Inventory_Start")
' Macro will import Genius data into next available line in the the Inventory unless the project title is already found within the Inventory list.
iReply = MsgBox("This will import the data provided in the Genius Data Worksheet, and possibly replace existing data with the information provided from the genius data export. Continue?", vbYesNo, "Validation Required")
If iReply = vbNo Then
Exit Sub
End If
For i = 0 To 2000
' It will then copy the data on top of the existing data.
' Next start searching in the Inventory to see if the project name already exists.
'pl = xlg.Offset(i, 3)
Set plr = ActiveWorkbook.Sheets("Inventory").Range("Project_List")
On Error GoTo NewProject ' Turn on error trapping
pRow = Application.WorksheetFunction.Match(pl, plr, 0) - 1
On Error GoTo 0 ' Turn off error trapping
GoTo ExistingProject
MsgBox (pl & " : " & pRow)
' If the project name already exists, jump to the Existing Project steps. If the project name does not exist, go to New Project steps.
NewProject:
pReply = MsgBox("This project does not exist in the inventory, do you want create a new project?", vbYesNo, "Validation Required")
If pReply = vbNo Then
Exit Sub
End If
Do Until xlr.Offset(k, 0) = "" 'find last row in inventory
k = k + 1
Loop
Err.Clear
GoTo UpdateFields
ExistingProject:
k = pRow 'set index to row of existing project found in inventory
UpdateFields:
' This section will copy the information from the Genius Data Sheet to the Inventory.
xlr.Offset(k, 0) = xlg.Offset(i, 3)
xlr.Offset(k, 1) = xlg.Offset(i, 0)
xlr.Offset(k, 2) = xlg.Offset(i, 10)
xlr.Offset(k, 3) = xlg.Offset(i, 11)
xlr.Offset(k, 18) = xlg.Offset(i, 1)
xlr.Offset(k, 19) = xlg.Offset(i, 6)
xlr.Offset(k, 20) = xlg.Offset(i, 5)
xlr.Offset(k, 21) = xlg.Offset(i, 4)
xlr.Offset(k, 22) = xlg.Offset(i, 18)
xlr.Offset(k, 42) = xlg.Offset(i, 58)
xlr.Offset(k, 43) = xlg.Offset(i, 60)
xlr.Offset(k, 46) = xlg.Offset(i, 41)
xlr.Offset(k, 48) = xlg.Offset(i, 42)
xlr.Offset(k, 50) = xlg.Offset(i, 43)
xlr.Offset(k, 54) = xlg.Offset(i, 46)
' This section adds the date when saving to the inventory unless Project has been saved to the inventory before.
If Range("Date_Created") = "" Then
xlr.Offset(k, 85) = Now()
Else
xlr.Offset(k, 85) = Range("Date_Created")
End If
If pl = "" Then
MsgBox ("All Genius Data was imported to the Inventory.")
Exit Sub
End If
Next i
End Sub

An additional question for experts (probably): Is it possible to only copy certain rows (that have the name "CIT-S" in column F?

Thank you very much!