EXCEL VBA FIND Value and then sum and then delete other row - excel

enter image description here[enter image description here][2]Hi,
I have an issue and hopefully someone can help. I have an Excel sheet and I Need to check if starting from last row if the same value as in column 4 from last row exists somewhere above, but condition is, that only if column 1 and column 2 are same and not in column 3 is the word "SK" or "SV" and then I Need to sum the values in column 7 and concaternate column 3 and column 6 and just Keep one line and the other which were the base of this calculation must be deleted.
Attached you will find the screenshots. First how the Excel file Looks like before processing and next screenshot how it should look like afterwards.
enter image description here

Here is the code:
Sub combine_data()
Dim vLastRow As Integer
Dim Col_A_Str As String
Dim Col_B_Str As String
Dim r As Integer
Dim vDatarow As Integer
Dim vCodeStr3 As String
Dim vCodeStr6 As String
Dim vTotal As Double
Dim Col_D_Str As String
vLastRow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
Col_A_Str = ""
Col_B_Str = ""
r = 1
vDatarow = 0
vCodeStr3 = ""
vCodeStr6 = ""
vTotal = 0
Col_D_Str = ""
Col_A_Str = Trim(Cells(vLastRow, 1))
Col_B_Str = Trim(Cells(vLastRow, 2))
Col_D_Str = Trim(Cells(vLastRow, 4))
Do Until r = vLastRow
DoEvents
If Trim(Cells(r, 4)) = Col_D_Str Then
If Trim(Cells(r, 1)) = Col_A_Str Then
If Trim(Cells(r, 2)) = Col_B_Str Then
If UCase(Trim(Cells(r, 3))) <> "SV" And UCase(Trim(Cells(r, 3))) <> "SK" Then
If vDatarow = 0 Then
If vDatarow = 0 Then vDatarow = r
vCodeStr3 = Trim(Cells(r, 3))
vCodeStr6 = Trim(Cells(r, 6))
vTotal = Cells(r, 7)
r = r + 1
Else
vCodeStr3 = vCodeStr3 & ", " & Trim(Cells(r, 3))
vCodeStr6 = vCodeStr6 & ", " & Trim(Cells(r, 6))
vTotal = vTotal + Cells(r, 7)
Cells(r, 1).EntireRow.Delete
vLastRow = vLastRow - 1
End If
Else
r = r + 1
End If
Else
r = r + 1
End If
Else
r = r + 1
End If
Else
r = r + 1
End If
Loop
Cells(vDatarow, 3).ClearContents
Cells(vDatarow, 3) = vCodeStr3
Cells(vDatarow, 6).ClearContents
Cells(vDatarow, 6) = vCodeStr6
Cells(vDatarow, 7).ClearContents
Cells(vDatarow, 7) = vTotal
End Sub

Related

VBA match function with multiple criteria

i am new here and this is my first question, also i dont speak english so my code (variables) is sometimes in dutch.
I have a workbook with multiple sheets (reservations, cottages, validator and schedule). Schedule needs to be filled in with the correct cottage for the reservation.
My question: I want the cottage_id to be returned with the match function. I need the cottage_id (Which is in column A of the cottagesheet), where the class is correct and where the cottage size is correct.
i've tried so much but nothing seems to work
i get error messages like 'type mismatch' and invalid procedure call or argument.
thankyou in advance!
My code:
Dim i As Integer
Dim c As Integer
Dim d As Integer
Dim numrows As Long
Dim laatstekolom As Long
Dim cottagerow As Variant
Dim class As Integer
Dim guests As Variant
Dim cottage_size As Integer
Dim som As Long
Dim somrng As Range
Dim resKlasse As Integer
Dim cottageId As Integer
Dim klasserij As Range
Dim maxpersrij As Range
Dim zoekklasse As Integer
Set roostersheet = Worksheets("rooster")
Set Reservationsheet = Worksheets("reservations")
Set Cottagesheet = Worksheets("cottages")
Set validatorsheet = Worksheets("validator")
Set lookupsheet = Worksheets("lookup")
roostersheet.Cells(1, 1) = "Cottage_id"
'datum uit reservationssheet naar header roostersheet
For i = 1 To 42
roostersheet.Cells(1, 2) = Reservationsheet.Cells(2, 2)
roostersheet.Cells(1, 2 + i) = Reservationsheet.Cells(2, 2) + i
Next i
'cottageid uit cottagesheet naar 1e kolom roostersheet
For i = 1 To 819
roostersheet.Cells(2, 1) = Cottagesheet.Cells(2, 1)
roostersheet.Cells(i + 2, 1) = Cottagesheet.Cells(2, 1) + i
Next i
'fixed in rooster plaatsen
numrows = Reservationsheet.UsedRange.Rows.Count
laatstekolom = roostersheet.UsedRange.Columns.Count
Resnr = validatorsheet.Range("A:A")
For i = 2 To numrows
If Reservationsheet.Cells(i, 16).Value <> 0 Then
cottagerow = Reservationsheet.Cells(i, 16).Value - 1
validatorsheet.Cells(i - 1, 2).Value = Reservationsheet.Cells(i, 16).Value
End If
For d = 2 To laatstekolom
If Reservationsheet.Cells(i, 2) = roostersheet.Cells(1, laatstekolom) Then
Range(roostersheet.Cells(cottagerow, datumkolom), roostersheet.Cells(cottagerow, laatstekolom + Reservationsheet.Cells(i, 3).Value - 1)).Value = Reservationsheet.Cells(i, 1).Value
End If
Next d
Next i
'reserveringen eisen sum = 0
For class = 4 To 1 Step -1
For i = 2 To numrows
guests = Reservationsheet.Cells(i, 4).Value
'juiste cottagesize
If guests = 1 Then
cottage_size = 2
ElseIf guests = 2 Then
cottage_size = 2
ElseIf guests = 3 Then
cottage_size = 4
ElseIf guests = 4 Then
cottage_size = 4
ElseIf guests = 5 Then
cottage_size = 5
ElseIf guests = 6 Then
cottage_size = 6
ElseIf guests = 7 Then
cottage_size = 8
ElseIf guests = 8 Then
cottage_size = 8
Else: cottage_size = 12
End If
zoekklasse = class
lookupsheet.Cells(1, 1).Value = zoekklasse
lookupsheet.Cells(1, 2).Value = cottage_size
If Application.WorksheetFunction.sum(Reservationsheet.Cells(i, 6), Reservationsheet.Cells(i, 15)) = 0 And Reservationsheet.Cells(i, 5).Value = class And Reservationsheet.Cells(i, 4).Value = cottage_size Then
Dim klasseKolom As Variant
Dim SizeKolom As Variant
Dim test As String
Set klasseKolom = Cottagesheet.UsedRange.Columns(3)
Set SizeKolom = Cottagesheet.UsedRange.Columns(2)
' cottageId = Application.Match(1, (klasseKolom = "&zoekklasse&") * (SizeKolom = "&cottage_size&"), 0)
cottageId = Evaluate("MATCH(1, ('lookupsheet'!A1="""&klasseKolom&""") * ('lookupsheet'!A2 = """&SizeKolom&"""), 0)")
'If Application.WorksheetFunction.sum(jjuyiReservationsheet.Cells(i, 6), Reservationsheet.Cells(i, 15)) = 0 And Reservationsheet.Cells(i, 5).Value = class and Then
'validatorsheet.Cells(cottageId, 2).Value = cottagesheet.Cells(i, 1).Value 'invullen in validatorsheet
'Else
'validatorsheet.Cells(i, 2).Value = "x"
End If
'ElseIf som <> 0 Then
Next i
Next class
End Sub
Try the following...
cottageId = Evaluate("MATCH(1,(" & klasseKolom.Address(External:=True) & "=" & zoekklasse & ")*(" & SizeKolom.Address(External:=True) & "=" & cottage_size & "),0)")
Then you can test whether there's a match as follows...
If Not IsError(cottageId) Then
MsgBox cottageId, vbInformation
Else
MsgBox "cottageId not found!", vbExclamation
End If

Shuffling a 2D array

I have the follow script to put a list of people with there know skills in an array and then match the first match with a customer with the same skill. Every time it runs the results are the same. I would like to have it be a random order of the array, but keeping the two columns in the array together. How can I shuffle(rearrange) the array that keeps the rows in the array the same? Or would it be better to erase the array, randomly sort the columns and set the array back up?
Sub Assign()
Dim arOne()
ReDim arOne(1000, 15)
Dim o As Integer
Dim p As Integer
Dim StartTime As Double
Dim MinutesElapsed As String
p = 0
o = 0
For i = 2 To 920
If Cells(i, 12).Value <> Cells(i - 1, 12) Then
p = p + 1
arOne(p, 0) = Cells(i, 12).Value
arOne(p, 1) = Cells(i, 13).Value
o = 2
Else
arOne(p, o) = Cells(i, 13).Value
o = o + 1
End If
Next
For i = 2 To 612
For o = LBound(arOne, 1) + 1 To UBound(arOne, 1)
If arOne(o, 0) <> "" Then
iUsed = Application.WorksheetFunction.CountIf(Range("C2:C" & i), "=" & arOne(o, 0))
If iUsed < Application.WorksheetFunction.VLookup(arOne(o, 0), Range("Q2:R62"), 2, False) Then
For j = LBound(arOne, 2) + 1 To UBound(arOne, 2)
If arOne(o, j) = Cells(i, 2).Value Then
Cells(i, 3).Value = arOne(o, 0)
ActiveSheet.Calculate
GoTo NextIR
End If
Next j
End If
End If
Next o
NextIR:
Next i
End Sub
Multiple loops and multiple access to range objects makes your code very, very slow (I don't know if performance is important).
I would read all necessary data to arrays and use filter and rnd to get a random person with the relevant skill:
Option Explicit
Sub PeopleBusiness()
Dim People, Customers, FilterArray
Dim I As Long, Idx As Long
People = Application.Transpose([L2:L920 & "|" & M2:M8])
Customers = Range("A2:C612").Value2
For I = 1 To UBound(Customers, 1)
FilterArray = Filter(People, Customers(I, 2))
If UBound(FilterArray) > -1 Then
Idx = Round(Rnd() * UBound(FilterArray), 0)
Customers(I, 3) = Left(FilterArray(Idx), InStr(1, FilterArray(Idx), "|") - 1)
End If
Next I
Range("A2:C612").Value = Customers
End Sub
I was able to get done what I needed by erasing the array and redimming it after sorting the data based on a rand() number in the table. It takes about 15 minutes to run 7000 assignment but it is a lot better than 7+ hours it takes to do manually.
Sub Assign()
Dim arOne()
ReDim arOne(1000, 15)
Dim o As Integer
Dim p As Integer
Dim StartTime As Double
Dim MinutesElapsed As String
Application.Calculation = xlAutomatic
StartTime = Timer
NextIR:
ReDim arOne(1000, 15)
p = 0
o = 0
QAlr = Sheets("Sheet1").Range("L" & Rows.Count).End(xlUp).Row
For I = 2 To QAlr
If Cells(I, 12).Value <> Cells(I - 1, 12) Then
p = p + 1
arOne(p, 0) = Cells(I, 12).Value
arOne(p, 1) = Cells(I, 13).Value
o = 2
Else
arOne(p, o) = Cells(I, 13).Value
o = o + 1
End If
Next
AQAlr = Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
AgtLr = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For I = AQAlr + 1 To AgtLr
For o = LBound(arOne, 1) + 1 To UBound(arOne, 1)
If arOne(o, 0) <> "" Then
iUsed = Application.WorksheetFunction.CountIf(Range("C2:C" & I), "=" & arOne(o, 0))
If iUsed < Application.WorksheetFunction.VLookup(arOne(o, 0), Range("Q2:R62"), 2, False) Then
For j = LBound(arOne, 2) + 1 To UBound(arOne, 2)
If arOne(o, j) = Cells(I, 2).Value Then
Cells(I, 3).Value = arOne(o, 0)
ActiveSheet.Calculate
Erase arOne()
ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort.SortFields.Add _
Key:=Range("Table1[[#All],[Random '#]]"), SortOn:=xlSortOnValues, Order:= _
xlDescending, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
GoTo NextIR
End If
Next j
End If
End If
Next o
Next I
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Assignments completed in " & MinutesElapsed & " minutes", vbInformation
End Sub
Not entirely sure I got your set-up right but you can try this:
Option Explicit
Sub Assign()
Randomize
Range("C2", Range("C" & Rows.Count).End(xlUp)).ClearContents
Dim R1 As Range: Set R1 = Range("L2:M920") 'People skill table
Dim R2 As Range: Set R2 = Range("A2:B612") 'Cusotmers skill talbe
Dim D0 As Object: Set D0 = CreateObject("scripting.dictionary")
Dim i As Integer, j As Integer, Rand as Integer
For i = 1 To R2.Rows.Count
Rand = Int(R1.Rows.Count * Rnd + 1)
For j = 1 To R1.Rows.Count
If R1.Cells(Rand, 2) = R2(i, 2) And Not D0.exists(Rand) Then
R2.Cells(i, 2).Offset(0, 1) = R1(Rand, 1)
D0.Add Rand, Rand
Exit For
End If
Rand = (Rand Mod R1.Rows.Count) + 1
Next j
Next i
End Sub
The idea is to check the people skill list starting from a random point and making sure a key is not used twice.
EDIT:
According to your comment I assume a "people / skill" can then be assigned more than once as there are 7000+ customers ?
Code below randomly assign with a fairly good distribution 1500 peoples to 7000 customers in +/- 1 second.
Have a try and see if you can adapt it to your project.
Option Explicit
Sub Assign()
Application.ScreenUpdating = False
Dim Start: Start = Timer
Randomize
Range("C2:C99999").ClearContents
Dim D1 As Object
Dim R1 As Range: Set R1 = Range("L2", Range("M" & Rows.Count).End(xlUp))
Dim R2 As Range: Set R2 = Range("A2", Range("B" & Rows.Count).End(xlUp))
Dim T1: T1 = R1
Dim T2: T2 = R2
Dim T3()
Dim a As Integer: a = 1
Dim i As Integer, j As Integer, k As Integer, Rnd_Val As Integer, j_loop As Integer
For i = 1 To (Int(R2.Rows.Count / R1.Rows.Count) + 1)
Set D1 = CreateObject("scripting.dictionary")
For j = (R1.Rows.Count * i - R1.Rows.Count + 1) To R1.Rows.Count * i
ReDim Preserve T3(1 To j)
Rnd_Val = Int(Rnd * R1.Rows.Count + 1)
For k = 1 To R1.Rows.Count
If T1(Rnd_Val, 2) = T2(j, 2) And Not D1.exists(Rnd_Val) And T3(j) = "" Then
T3(j) = T1(Rnd_Val, 1)
D1.Add Rnd_Val, Rnd_Val
Exit For
End If
Rnd_Val = (Rnd_Val Mod R1.Rows.Count) + 1
Next k
If T3(j) = "" Then
For k = 1 To R1.Rows.Count
If T1(Rnd_Val, 2) = T2(j, 2) Then
T3(j) = T1(Rnd_Val, 1)
Exit For
End If
Rnd_Val = (Rnd_Val Mod R1.Rows.Count) + 1
Next k
End If
a = a + 1
If a > R2.Rows.Count Then GoTo EndLoop
Next j
Set D1 = Nothing
Next i
EndLoop:
Range("C2").Resize(UBound(T3), 1) = Application.Transpose(T3)
Debug.Print Timer - Start
Application.ScreenUpdating = True
End Sub

Need to choose files manually instead of directing the vb code to a folderpath

I did a vb code which is reading multiple text files from a folder and then parsing specific data from it. In the code I have hard coded a folderpath strPath = "C:\Users\smim\Desktop\Mim\Excel\". Now I would like to be able to choose the folder and files manually instead of hard coding the folder path. Here is my code :
Sub Parse()
Dim ws As Worksheet
Dim MyData As String, strData() As String
Dim WriteToRow As Long, i As Long
Dim strCurrentTxtFile As String
Dim count As Variant, yellow As Variant, red As Variant,
Dim YellowC As Variant,RedC As Variant, filecounter As Variant
Dim strPath As String
Application.ScreenUpdating = False
count = 0
red = 0
yellow = 0
YellowC = 0
RedC = 0
strPath = "C:\Users\smim\Desktop\Mim\Excel\"
'Set Book3 = Sheets("Sheet1")
Set ws = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
MsgBox ("Started")
'~~> Start from Row 1
'WriteToRow = 1
Cells(3, 1) = "Error"
Cells(3, 1).Interior.ColorIndex = 3
Cells(3, 2) = "Warnings"
Cells(3, 2).Interior.ColorIndex = 6
Cells(1, 3) = "Error"
Cells(1, 3).Interior.ColorIndex = 3
Cells(2, 3) = "Warnings"
Cells(2, 3).Interior.ColorIndex = 6
strCurrentTxtFile = Dir(strPath & "test_*.txt")
' MsgBox (strCurrentTxtFile)
'~~> Looping through all text files in a folder
Do While strCurrentTxtFile <> ""
Dim list() As String
'~~> Open the file in 1 go to read it into an array
Open strPath & strCurrentTxtFile For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbLf)
LineCount = UBound(strData)
' MsgBox (LineCount)
'Assigning length of the list array
ReDim Preserve list(LineCount + 1)
For x = 0 To (LineCount - 1)
'For x = LBound(strData) To UBound(strData)
'Parsing each line to get the result only ( after = sign)
s = Split(strData(x), "=")
b = UBound(s)
'MsgBox (s(1))
'Assigning Values to the list array
list(x) = s(1)
Next
'MsgBox ("This is list" & list(2))
'Active Cell 2
Range("A2").Activate
'Get row number
dblRowNo = ActiveCell.Row
'Get col number
dblColNo = ActiveCell.Column
'MsgBox (dblColNo)
' ReDim Preserve list(LineCount)
For i = 0 To (LineCount - 1)
Cells(3, 3 + i + 1).Value = i
'Looping and assigning Values to the Cell
'For i = LBound(strData) To UBound(strData)
tempParsing = Split(list(i), ":")
' MsgBox (tempParsing(0))
If tempParsing(0) > 0 And tempParsing(0) < 10 Then
Cells(dblRowNo + count + 2, dblColNo + i + 3).Interior.ColorIndex = 6
yellow = yellow + 1
ElseIf tempParsing(0) >= 10 Then
Cells(dblRowNo + count + 2, dblColNo + i + 3).Interior.ColorIndex = 3
red = red + 1
ElseIf tempParsing(0) = 0 Then
Cells(dblRowNo + count + 2, dblColNo + i + 3).Interior.ColorIndex = 0
End If
'Looping and assigning Values to the Cell
' For i = LBound(strData) To UBound(strData)
Cells(dblRowNo + count + 2, dblColNo + 1) = yellow
Cells(dblRowNo + count + 2, dblColNo) = red
Cells(dblRowNo + count + 2, dblColNo + i + 3).Value = list(i)
Next
Cells(3 + count + 1, 3).Value = count
count = count + 1
yellow = 0
red = 0
strCurrentTxtFile = Dir
Loop
For t = 4 To 175
If Cells(t, 1).Value > 0 Then
Cells(t, 1).Interior.ColorIndex = 3
End If
If Cells(t, 2).Value > 0 Then
Cells(t, 2).Interior.ColorIndex = 6
End If
Next
'Cells(9, 1) = "linecount = "
'Cells(9, 2) = LineCount
MsgBox "Done"
For f = 4 To 175
If Cells(f, 4).Interior.ColorIndex = 6 Then
YellowC = YellowC + 1
ElseIf Cells(f, 4).Interior.ColorIndex = 3 Then
RedC = RedC + 1
End If
Next
For g = 4 To 175
If Cells(g, 7).Interior.ColorIndex = 6 Then
YellowC = YellowC + 1
ElseIf Cells(g, 7).Interior.ColorIndex = 3 Then
RedC = RedC + 1
End If
Next
For u = 0 To (LineCount - 1)
Cells(dblRowNo, dblColNo + u + 3) = YellowC
Cells(1, dblColNo + u + 3) = RedC
Next
YellowC = 0
RedC = 0
Application.ScreenUpdating = True
End Sub

Faster matching code

I have a code that takes a list of Airline flightlegs and matches them up to give me full lines of flight. The code works but..... it takes a very long time (45-60 min for just 35,000 rows) due to the amount of data it has to go through. This is compounded and the overall code takes about 2 hours to run. Is there a faster method to get the same results?
Here is my current code that really bogs down the entire process:
Sub BuildingLines()
'strings together segments into trip
Dim i As Long
Dim z As Long
Dim T As Long
Dim c As Long
Dim a As Long
Dim f As Long
Dim l As Long
Dim g As Long
Dim y As String
Dim b As String
Set ref = Sheets("Ref")
With Sheets("MoveData")
z = .Cells(1, 1).End(xlDown).Row
x = .Cells(2, 1).End(xlToRight).Column
Range(.Cells(1, 3), (.Cells(z, x + 3))).Clear
z = .Cells(1, 1).End(xlDown).Row
g = ref.Cells(24, 1).End(xlDown).Row
For a = 24 To g
If ref.Cells(a, 2) = "" Then GoTo nexta
f = ref.Cells(a, 2)
c = ref.Cells(a, 3)
l = ref.Cells(a, 4)
Set LegTable = Range(.Cells(f, 1), .Cells(l, 1))
For i = f To l
Application.StatusBar = "Progress: Step 5 of 20 - Building lines for " & ref.Cells(a, 1) & " (" & (a - 23) & " A/C types of " & (g - 23) & ") : " & (i - f) + 1 & " Legs of " & c & " analyzed. (" & Format(((i - f) + 1) / c, "Percent") & ")"
DoEvents
'On Error GoTo NextI
If IsError(Application.Match(.Cells(i, 2), LegTable, 0)) Then
GoTo nexti
Else
y = Application.Match(.Cells(i, 2), LegTable, 0) + f - 1
.Cells(i, 1).End(xlToRight).Offset(0, 1).Value2 = .Cells(y, 2)
Do
'On Error GoTo NextI
If IsError(Application.Match(.Cells(y, 2), LegTable, 0)) Then
GoTo nexti
Else
b = Application.Match(.Cells(y, 2), LegTable, 0) + f - 1
h = .Cells(b, 2)
.Cells(i, 1).End(xlToRight).Offset(0, 1) = h
y = b
End If
Loop
nexti:
End If
b = ""
y = ""
Next i
nexta:
Next a
End With
End Sub
The data is all string data of about 50+ chars.
Thank you for any recomendations.
Thank you very much A.S.H. with your help, I not only learned alot about using arrays, but also ended up cutting my runtime from about 90 minutes to just over 3 minutes. This is my final working code that used a combination of your suggestions.
Sub BuildingLines()
'strings together segments into trip
Dim i As Long
Dim z As Long
Dim c As Long
Dim f As Long
Dim l As Long
Dim LegTable As Range
Dim TurnTable As Range
Dim FirstTurn() As Variant
Dim NextTurn() As Variant
Dim y As String
Dim b As String
Dim FTtext As String
Dim wb As Workbook
Dim ref As Worksheet
Set wb = ThisWorkbook
Set ref = wb.Sheets("Ref")
With Sheets("MoveData")
z = .Cells(1, 1).End(xlDown).Row
x = .Cells(2, 1).End(xlToRight).Column
Range(.Cells(1, 3), (.Cells(z, x + 3))).Clear
z = .Cells(1, 1).End(xlDown).Row
g = ref.Cells(24, 1).End(xlDown).Row
For a = 24 To g
If ref.Cells(a, 2) = "" Then GoTo NextA
f = ref.Cells(a, 2)
c = ref.Cells(a, 3)
l = ref.Cells(a, 4)
Set LegTable = Range(.Cells(f, 1), .Cells(l, 1))
Set TurnTable = Range(.Cells(f, 1), .Cells(l, 2))
FirstTurn = TurnTable
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=LegTable, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange TurnTable
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For i = f To l
Application.StatusBar = "Progress: Step 5 of 20 - Building lines for " & ref.Cells(a, 1) & " (" & (a - 23) & " A/C types of " & (g - 23) & ") : " & (i - f) + 1 & " Legs of " & c & " analyzed. (" & Format(((i - f) + 1) / c, "Percent") & ")"
DoEvents
y = 0
b = 0
y = Application.Match(.Cells(i, 2), LegTable, 1)
If .Cells(i, 2) <> FirstTurn(y, 1) Then GoTo NextI
NextLeg = NextLeg + 1
ReDim Preserve NextTurn(0, 1 To NextLeg)
NextTurn(0, NextLeg) = FirstTurn(y, 2)
Do
FTtext = FirstTurn(y, 2)
On Error GoTo errhdlr
b = Application.WorksheetFunction.Match(FTtext, LegTable, 1)
If FTtext <> FirstTurn(b, 1) Then GoTo NextI
NextLeg = NextLeg + 1
ReDim Preserve NextTurn(0, 1 To NextLeg)
NextTurn(0, NextLeg) = FirstTurn(b, 2)
y = b
Loop
errhdlr:
Resume NextI
NextI:
If NextLeg > 0 Then Range(.Cells(i, 3), .Cells(i, NextLeg + 2)).Value = NextTurn
Erase NextTurn
NextLeg = 0
Next i
Set LegTable = Nothing
Set TurnTable = Nothing
Erase NextTurn
Erase FirstTurn
NextA:
Next a
End With
End Sub
I first tried using just the arrays, but the Match function was WAY SLOWER in the arrays. So I ended up using the Match to find the index and then grabbed the data from the array to build my second array which then became my output. I can't wait to adapt my new found knowledge with the rest of this project and cut my runtime from 2+ hours to just minutes!! Thanks, again!!!

Bad File Name when using Excel to find words in a Word Document

I'm using the code below to loop through some data on an Excel spreadsheet and open a Word document. I want to then cycle through a word document and find all of the words that were on the Excel sheet. This works okay until I try and find the words on the Excel sheet and then I get a "bad file name" message. I've highlighted the line below where the error occurs. I'm sure it is a syntax error, I just don't know what the correct syntax is. Thanks for the help.......
Dim MyDB() As String
Dim MyCol() As String
Dim MyDBCnt As Integer
Dim MyColCnt As Integer
Dim DBCnt As Integer
Dim ResRow As Integer
Dim r As Integer
Dim x As Integer
Dim PrevRow As Integer
ResRow = 1
r = 5
x = 1
PrevRow = 4
Do Until Len(Trim(Cells(r, 4))) + Len(Trim(Cells(r, 5))) = 0
DoEvents
ReDim Preserve MyDB(1 To x)
If (Trim(Cells(r, 4)) & "." & Trim(Cells(r, 5))) = (Trim(Cells(PrevRow, 4)) & "." & Trim(Cells(PrevRow, 5))) Then
' do nothing
Else
MyDB(x) = Trim(Cells(r, 4)) & "." & Trim(Cells(r, 5))
x = x + 1
End If
r = r + 1
PrevRow = PrevRow + 1
Loop
x = x - 1
MyDBCnt = x
r = 5
x = 1
Do Until Len(Trim(Cells(r, 4))) + Len(Trim(Cells(r, 5))) = 0
DoEvents
ReDim Preserve MyCol(1 To x)
MyCol(x) = Trim(Cells(r, 6))
r = r + 1
x = x + 1
Loop
x = x - 1
MyColCnt = x
Worksheets("Results").Activate
MyLastRow = Cells.Find("*", [a1], , , xlByRows, xlPrevious).Row
ResRow = MyLastRow
Set WordApp = CreateObject("word.Application")
Set WordDoc = WordApp.Documents.Open("R:\Report Web\SQL Doc.docx")
WordApp.Visible = True
WordDoc.Activate
tmp = WordDoc.Name
Dim j As Integer
DBCnt = 1
With WordApp.Selection
Do Until DBCnt > MyDBCnt
DoEvents
With Documents(WordDoc).Find ***ERROR OCCURS HERE
.Text = MyDB(DBCnt)
j = 0
Do While .Execute(Forward:=True) = True
DoEvents
j = j + 1
Loop
End With
If j > 0 Then
MsgBox MyDB(DBCnt) & " was found " & j & " times."
End If
DBCnt = DBCnt + 1
Loop
End With
Find is not a valid property of the Document object. You need to use it on either the Selection or the Range object. For example:
Dim rngFind as Word.Range
Set rngFind = WordDoc.Content
With rngFind.Find
End With

Resources