V
vbastarter
Hi I had a post here asking if my loops that run very slowly can be made any
quick.
One suggestion was to replace with an Array.
Now I'm new to VBA and have no idea how to go about Arrays. Below is my code
where I'm finding dulicates based on name fields deleting from that and
adding to another sheet. Here I have 2 text boxes to enter position of Names
Fields and and an option to choose entire FName to be searched instead of
just FName initial.
Now all that I did is replace my r and k range with arrays but I get and
error at this line : If Trim(UCase(Array1(i).Cells(n, strFNameCol))) =
Trim(UCase(Array1(i).Cells(m, strFNameCol))) And _
Trim(UCase(Array1(i).Cells(n, strLNameCol))) = Trim(UCase(Array1(i).Cells(m,
strLNameCol))) . It says runtime error "Runtime error 9 Subscript out of
Range"
My code as below:
Private Sub CmdSubmitNames_Click()
Dim r As Range, _
k As Range
Dim sh As Excel.Worksheet
Dim strFNameCol As String, _
strLNameCol As String
Dim intCounter As Integer, _
intTotDB As Integer, _
totRows As Integer, _
intDupFound As Integer, _
intTotDB2 As Integer, _
i As Integer, _
intTotfile As Integer
Dim Array1(), _
Array2()
totRows = 1026
intCounter = 0
strFNameCol = TxtFNCol.Value
strLNameCol = TxtLNCol.Value
Set r = ActiveWorkbook.ActiveSheet.Range("A:AS")
Set sh = ActiveWorkbook.Worksheets.Add
Set k = sh.Range("A:AS")
Array1 = r.Value
Array2 = k.Value
intTotDB = 1
n = 2
For n = 2 To 1000
If (Array1(i).Cells(n, strFNameCol)) <> "" Or _
(Array1(i).Cells(n, strLNameCol)) <> "" Then
For m = n + 1 To 1000
If OptEntireFNSearch Then
If Trim(UCase(Array1(i).Cells(n, strFNameCol))) =
Trim(UCase(Array1( i).Cells(m, strFNameCol))) And _
Trim(UCase(Array1(i).Cells(n, strLNameCol))) =
Trim(UCase(Array1(i).Cells(m, strLNameCol))) Then
intDupFound = 1
Array2(i).Rows(intTotDB).Value = Array1(i).Rows(m).Value
intTotDB = intTotDB + 1
Array1(i).Rows(m).Delete
m = m - 1
totRows = totRows - 1
End If
Else
If Trim(UCase(Left(Array1(i).Cells(n, strFNameCol), 1))) =
Trim(UCase(Left(Array1(i).Cells(m, strFNameCol), 1))) And _
Trim(UCase(Array1(i).Cells(n, strLNameCol))) =
Trim(UCase(Array1(i).Cells(m, strLNameCol))) Then
intDupFound = 1
Array2(i).Rows(intTotDB).Value = Array1(i).Rows(m).Value
intTotDB = intTotDB + 1
Array1(i).Rows(m).Delete
m = m - 1
totRows = totRows - 1
End If
End If
Next m
If intDupFound = 1 Then
Array2(i).Rows(intTotDB).Value = Array1(i).Rows(n).Value
intTotDB = intTotDB + 1
Array1(i).Rows(n).Delete
totRows = totRows - 1
n = n - 1
intDupFound = 0
End If
End If
Next n
End_of_Data:
MsgBox "Data Extracted"
End Sub
Thanks In Advance
quick.
One suggestion was to replace with an Array.
Now I'm new to VBA and have no idea how to go about Arrays. Below is my code
where I'm finding dulicates based on name fields deleting from that and
adding to another sheet. Here I have 2 text boxes to enter position of Names
Fields and and an option to choose entire FName to be searched instead of
just FName initial.
Now all that I did is replace my r and k range with arrays but I get and
error at this line : If Trim(UCase(Array1(i).Cells(n, strFNameCol))) =
Trim(UCase(Array1(i).Cells(m, strFNameCol))) And _
Trim(UCase(Array1(i).Cells(n, strLNameCol))) = Trim(UCase(Array1(i).Cells(m,
strLNameCol))) . It says runtime error "Runtime error 9 Subscript out of
Range"
My code as below:
Private Sub CmdSubmitNames_Click()
Dim r As Range, _
k As Range
Dim sh As Excel.Worksheet
Dim strFNameCol As String, _
strLNameCol As String
Dim intCounter As Integer, _
intTotDB As Integer, _
totRows As Integer, _
intDupFound As Integer, _
intTotDB2 As Integer, _
i As Integer, _
intTotfile As Integer
Dim Array1(), _
Array2()
totRows = 1026
intCounter = 0
strFNameCol = TxtFNCol.Value
strLNameCol = TxtLNCol.Value
Set r = ActiveWorkbook.ActiveSheet.Range("A:AS")
Set sh = ActiveWorkbook.Worksheets.Add
Set k = sh.Range("A:AS")
Array1 = r.Value
Array2 = k.Value
intTotDB = 1
n = 2
For n = 2 To 1000
If (Array1(i).Cells(n, strFNameCol)) <> "" Or _
(Array1(i).Cells(n, strLNameCol)) <> "" Then
For m = n + 1 To 1000
If OptEntireFNSearch Then
If Trim(UCase(Array1(i).Cells(n, strFNameCol))) =
Trim(UCase(Array1( i).Cells(m, strFNameCol))) And _
Trim(UCase(Array1(i).Cells(n, strLNameCol))) =
Trim(UCase(Array1(i).Cells(m, strLNameCol))) Then
intDupFound = 1
Array2(i).Rows(intTotDB).Value = Array1(i).Rows(m).Value
intTotDB = intTotDB + 1
Array1(i).Rows(m).Delete
m = m - 1
totRows = totRows - 1
End If
Else
If Trim(UCase(Left(Array1(i).Cells(n, strFNameCol), 1))) =
Trim(UCase(Left(Array1(i).Cells(m, strFNameCol), 1))) And _
Trim(UCase(Array1(i).Cells(n, strLNameCol))) =
Trim(UCase(Array1(i).Cells(m, strLNameCol))) Then
intDupFound = 1
Array2(i).Rows(intTotDB).Value = Array1(i).Rows(m).Value
intTotDB = intTotDB + 1
Array1(i).Rows(m).Delete
m = m - 1
totRows = totRows - 1
End If
End If
Next m
If intDupFound = 1 Then
Array2(i).Rows(intTotDB).Value = Array1(i).Rows(n).Value
intTotDB = intTotDB + 1
Array1(i).Rows(n).Delete
totRows = totRows - 1
n = n - 1
intDupFound = 0
End If
End If
Next n
End_of_Data:
MsgBox "Data Extracted"
End Sub
Thanks In Advance