[color=blue]Option[/color] [color=blue]Explicit[/color] [color=lightgreen]'Not necerssary but forces to dim everything, reducing memory and making errors more obvios[/color]
[color=blue]Sub[/color] Code1_SpiderjamPricePullVBAArrayLooping()
[color=blue]Dim[/color] wsPrices [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wsPrices = ThisWorkbook.Worksheets("Prices Spreadsheet") [color=lightgreen]'Give the abbreviations the variuos Methods Properties, etc. of ...[/color]
[color=blue]Dim[/color] wsMain [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wsMain = ThisWorkbook.Worksheets("W-ElectBulk") [color=lightgreen]'Worksheets Object (Obtainable through typing . dot )[/color]
[color=lightgreen]'Define start row numbers in sheets[/color]
[color=blue]Dim[/color] sP [color=blue]As[/color] [color=blue]Long[/color], sM [color=blue]As[/color] Long: [color=blue]Let[/color] sP = 4: [color=blue]Let[/color] sM = 15
[color=lightgreen]'Define Ranges for Data Arrays and "Capture" the data values..[/color]
[color=blue]Dim[/color] DescP() [color=blue]As[/color] [color=blue]Variant[/color], DescM() [color=blue]As[/color] [color=blue]Variant[/color] [color=lightgreen]' Descriptions Array Variables must be dynamic to work in next lines[/color]
[color=blue]Let[/color] DescP() = wsPrices.Range("A" & sP & ":A" & wsPrices.Cells(Rows.Count, 1).End(xlUp).Row & "").Value [color=lightgreen]'One line "capture" of values of spradsheet to dynamic array is conveniently allowed by VBA and the last row here is...[/color]
[color=blue]Let[/color] DescM() = wsMain.Range("A" & sM & ":A" & wsMain.Cells(Rows.Count, 1).End(xlUp).Row & "").Value [color=lightgreen]'determined by by quasi going to the last row in first column and going backUp untill a cell with something in it is found (.End Property, and then obtaining the that row number from the row property[/color]
[color=blue]Dim[/color] PricesP() [color=blue]As[/color] [color=blue]Variant[/color], PricesM() [color=blue]As[/color] [color=blue]Variant[/color] [color=lightgreen]'Prices , and Prices to pull data Arrays[/color]
[color=blue]Let[/color] PricesP() = wsPrices.Range("H" & sP & ":H" & wsPrices.Cells(Rows.Count, 1).End(xlUp).Row & "").Value [color=lightgreen]'Column H for prices, (last row that for column A)[/color]
[color=blue]ReDim[/color] PricesM(1 [color=blue]To[/color] [color=blue]UBound[/color](DescM(), 1), 1 [color=blue]To[/color] [color=blue]UBound[/color](DescM(), 2)) [color=lightgreen]'For now leave the output array empty, but give it a consistant size for later looping[/color]
[color=lightgreen]'Main Looping to check for similar Descriptions[/color]
[color=blue]Dim[/color] rP [color=blue]As[/color] [color=blue]Long[/color], rM [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'variables for rows within the arrays[/color]
[color=blue]For[/color] rP = 1 [color=blue]To[/color] [color=blue]UBound[/color](DescP(), 1) [color=lightgreen]'go down each price row, and for each of these rows...[/color]
[color=blue]For[/color] rM = 1 [color=blue]To[/color] [color=blue]UBound[/color](DescM(), 1) [color=lightgreen]'go down the entire Main desription[/color]
[color=lightgreen]'This is the bit where some tricky comparisons must be made[/color]
[color=lightgreen]' Debug.Print "DescP=" & DescP(rP, 1) & " DescM=" & DescM(rM, 1)[/color]
[color=lightgreen]' Debug.Print VBA.Mid(DescM(rM, 1), 2, 15)[/color]
[color=lightgreen]'[/color]
' Debug.Print VBA.Right(DescP(rP, 1), 20)
[color=lightgreen]' Debug.Print VBA.Right(DescM(rM, 1), 20)[/color]
[color=blue]If[/color] VBA.InStr(1, DescP(rP, 1), (VBA.Mid(DescM(rM, 1), 2, 15)), 0) > 1 [color=blue]Or[/color] VBA.Right(DescP(rP, 1), 33) = VBA.Right(DescM(rM, 1), 33) [color=blue]Then[/color] [color=lightgreen]'[/color]
'If VBA.Right(DescP(rP, 1), 20) = VBA.Right(DescM(rM, 1), 20) Then 'Check for match in lastparts in both lists
[color=lightgreen]'If VBA.InStr(1, DescP(rP, 1), (VBA.Mid(DescM(rM, 1), 2, 15)), 0) > 1 Then 'Check for part of description im main row in full description in prices[/color]
[color=blue]Let[/color] PricesM(rM, 1) = PricesP(rP, 1) [color=lightgreen]'Put price for matched description in Main Price Array[/color]
[color=blue]Else[/color] [color=lightgreen]' No near match so do nothing[/color]
[color=blue]End[/color] [color=blue]If[/color]
[color=blue]Next[/color] rM
[color=blue]Next[/color] rP
[color=lightgreen]'Output main prices[/color]
[color=blue]Let[/color] wsMain.Range("D" & sM & "").Resize(UBound(PricesM(), 1)) = PricesM() [color=lightgreen]'A typical VBA Allowse "One Liner" Output of an Array to a Range: Resize the output start cell to the size of the array and then make the values of that range equal to the array[/color]
[color=blue]End[/color] [color=blue]Sub[/color] [color=lightgreen]'Code1_SpiderjamPricePullVBAArrayLooping()[/color]
[color=lightgreen]'[/color]
'
'
'
'
[color=lightgreen]'[/color]
[color=blue]Sub[/color] Code2_SpiderjamPricePull_MatchWithOnError()
On [color=blue]Error[/color] [color=blue]GoTo[/color] TheEnd [color=lightgreen]'Main error handler for unexpected errors - go to near the end and do anything important should an unexpected error occur[/color]
[color=blue]Dim[/color] wsPrices [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wsPrices = ThisWorkbook.Worksheets("Prices Spreadsheet") [color=lightgreen]'Give the abbreviations the variuos Methods Properties, etc. of ...[/color]
[color=blue]Dim[/color] wsMain [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wsMain = ThisWorkbook.Worksheets("W-ElectBulk") [color=lightgreen]'Worksheets Object (Obtainable through typing . dot )[/color]
wsPrices.Columns(10).ClearContents [color=lightgreen]'Clear the column that I later use for a temporary range in the .Match second argument.[/color]
[color=lightgreen]'Define start row numbers in sheets[/color]
[color=blue]Dim[/color] sP [color=blue]As[/color] [color=blue]Long[/color], sM [color=blue]As[/color] Long: [color=blue]Let[/color] sP = 4: [color=blue]Let[/color] sM = 15
[color=lightgreen]'Define Ranges for Data Arrays and "Capture" the data values..[/color]
[color=blue]Dim[/color] DescP() [color=blue]As[/color] [color=blue]Variant[/color], DescM() [color=blue]As[/color] [color=blue]Variant[/color] [color=lightgreen]' Descriptions Array Variables, - must be dynamic to work in next lines[/color]
[color=blue]Let[/color] DescP() = wsPrices.Range("A" & sP & ":A" & wsPrices.Cells(Rows.Count, 1).End(xlUp).Row & "").Value [color=lightgreen]'[color=blue]On[/color]e line "capture" of values of spradsheet to dynamic array is conveniently allowed by VBA and the last row here is...[/color]
[color=blue]Let[/color] DescM() = wsMain.Range("A" & sM & ":A" & wsMain.Cells(Rows.Count, 1).End(xlUp).Row & "").Value [color=lightgreen]'determined by by quasi going to the last row in first column and going backUp untill a cell with something in it is found (.End Property, and then obtaining the that row number from the row property[/color]
[color=blue]Dim[/color] PricesP() [color=blue]As[/color] [color=blue]Variant[/color], PricesM() [color=blue]As[/color] [color=blue]Variant[/color] [color=lightgreen]'Prices , and Prices to pull data Arrays[/color]
[color=blue]Let[/color] PricesP() = wsPrices.Range("H" & sP & ":H" & wsPrices.Cells(Rows.Count, 1).End(xlUp).Row & "").Value [color=lightgreen]'Column H for prices, (last row that for column A)[/color]
[color=blue]ReDim[/color] PricesM(1 [color=blue]To[/color] [color=blue]UBound[/color](DescM(), 1), 1 [color=blue]To[/color] [color=blue]UBound[/color](DescM(), 2)) [color=lightgreen]'For now leave the output array empty, but give it a consistant size for later looping[/color]
[color=lightgreen]'Create Arrays for Right end of descriptions, - it may look like a lot of extra overhead for code, But VBA Array workings go very fast[/color]
[color=blue]Dim[/color] rP [color=blue]As[/color] [color=blue]Long[/color], rM [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'variables for rows within the arrays[/color]
[color=blue]Dim[/color] RechtsMain() [color=blue]As[/color] [color=blue]String[/color], RechtsPrices() [color=blue]As[/color] [color=blue]String[/color] [color=lightgreen]' We are going to make these fixed dimension arrays so an assign string type[/color]
[color=blue]ReDim[/color] RechtsMain(1 [color=blue]To[/color] [color=blue]UBound[/color](DescM(), 1), 1 [color=blue]To[/color] [color=blue]UBound[/color](DescM(), 2)) [color=lightgreen]'Use ReDim just as Dim only takes numbers does not take Variables[/color]
[color=blue]For[/color] rM = 1 [color=blue]To[/color] [color=blue]UBound[/color](DescM(), 1) [color=blue]Step[/color] 1
RechtsMain(rM, 1) = VBA.Right(DescM(rM, 1), 20)
[color=blue]Next[/color] rM
[color=blue]ReDim[/color] RechtsPrices(1 [color=blue]To[/color] [color=blue]UBound[/color](DescP(), 1), 1 [color=blue]To[/color] [color=blue]UBound[/color](DescP(), 2))
[color=blue]For[/color] rP = 1 [color=blue]To[/color] [color=blue]UBound[/color](DescP(), 1) [color=blue]Step[/color] 1
RechtsPrices(rP, 1) = VBA.Right(DescP(rP, 1), 20)
[color=blue]Next[/color] rP
[color=blue]Let[/color] wsPrices.Range("J1").Resize(UBound(DescP(), 1), 1).Value = RechtsPrices() [color=lightgreen]'Write out a column to use in Application.Match - resize J1 to size of array for right bit of prices description then assign the values of this range to the array in this allowed "VBA one liner"[/color]
[color=lightgreen]'Main ONE LOOP to check for similar Descriptions[/color]
[color=lightgreen]'For rP = 1 To UBound(DescP(), 1) 'go down each price row, and for each of these rows...'NOT NEEDED IN Code2[/color]
[color=blue]For[/color] rM = 1 [color=blue]To[/color] [color=blue]UBound[/color](DescM(), 1) [color=lightgreen]'go down the entire Main desription[/color]
[color=lightgreen]'This is the bit where some tricky comparisons must be made[/color]
[color=lightgreen]' Debug.Print "DescP=" & DescP(rP, 1) & " DescM=" & DescM(rM, 1)[/color]
[color=lightgreen]' Debug.Print VBA.Mid(DescM(rM, 1), 2, 15)[/color]
[color=lightgreen]' Debug.Print VBA.Right(DescP(rP, 1), 33)[/color]
[color=lightgreen]'If VBA.InStr(1, DescP(rP, 1), (VBA.Mid(DescM(rM, 1), 2, 15)), 0) > 1 Or VBA.Right(DescP(rP, 1), 33) = DescM(rM, 1) Then ' Check for part of dscription im main row in full description in prices[/color]
[color=lightgreen]'If VBA.Right(DescP(rP, 1), 20) = VBA.Right(DescM(rM, 1), 20) Then 'Check for match in lastparts in both lists[/color]
[color=lightgreen]'If RechtsPrices(rP, 1) = RechtsMain(rM, 1) Then 'Check for match in lastparts in both lists[/color]
[color=blue]On[/color] [color=blue]Error[/color] [color=blue]GoTo[/color] nextbit [color=lightgreen]' This intended to make VBA go on to the next Main Row, rather than crashing if no match is found , as this would cause the .Match Function to error - We expect this error to sometimes occur, there are many alternatives to this method that will not error, for example http://www.excelforum.com/excel-new-users-basics/1072093-match-with-on-error-on-error-resume-next-works-on-error-goto-only-works-once-err-clear.html , but I am playing with error here for fun. I can reassign ann error handler as long as the exception is not raised####[/color]
[color=lightgreen]'Let rP = Application.WorksheetFunction.Match(RechtsMain(rM, 1), wsPrices.Columns(10), 0) 'If this finds a match (so does not error) it returns the row number for the Prices array where the match occurred[/color]
[color=blue]Let[/color] rP = Application.WorksheetFunction.Match(RechtsMain(rM, 1), wsPrices.Range("J1:J" & wsPrices.Cells(Rows.Count, 10).End(xlUp).Row & ""), 0) [color=lightgreen]'Found in the practice that a specific range rather thann the whole column for the arrgument tended to work quicker : Post #6 http://www.mrexcel.com/forum/excel-questions/792647-simple-data-sort-merge-code.html[/color]
[color=blue]Let[/color] PricesM(rM, 1) = PricesP(rP, 1) [color=lightgreen]'Put price for matched description in Main Price Array[/color]
nextbit: On Error [color=blue]GoTo[/color] -1 [color=lightgreen]'Clears the exception####, that means, get VBA out of its "I think error are being handeled so I will get confused and go back to defailt mode if another comes along". Does not disable the On Error GoTo error handler but Deactivates that error handler so it can be used again.[/color]
[color=blue]Next[/color] rM [color=lightgreen]' Go to next main row[/color]
[color=lightgreen]'On Error GoTo -1' Not needed in this case as it would have been done in any event a couple of lines above[/color]
[color=lightgreen]'[color=blue]On[/color] [color=blue]Error[/color] GoTo 0 'disables (kills) last goto error handler, actually also not needed - can re assign an error handler, if it is not switched on[/color]
On Error [color=blue]GoTo[/color] TheEnd [color=lightgreen]'Enable the original main error handler - On Error GoTo -1 has Cleared the exception and On Error GoTo 0 has killed the last so we can enable a new one (active)[/color]
[color=lightgreen]'Next rP' NOT NEEDED IN Code2[/color]
[color=lightgreen]'Output main prices[/color]
[color=blue]Let[/color] wsMain.Range("D" & sM & "").Resize(UBound(PricesM(), 1)) = PricesM() [color=lightgreen]'A typical VBA Allowse "One Liner" Output of an Array to a Range: Resize the output start cell to the size of the array and then make the values of that range equal to the array[/color]
TheEnd:
[color=lightgreen]'Do anything here you should in the case of an error, like turning any important things back on[/color]
wsPrices.Columns(10).ClearContents [color=lightgreen]'Clear contents of column used for tempory range for use in .Match second argument.[/color]
[color=blue]End[/color] [color=blue]Sub[/color] [color=lightgreen]'Code2_SpiderjamPricePull_MatchWithOnError()[/color]
[color=lightgreen]'[/color]