Long Loop Time

[sheeeng]

Hi all! :hi:

I have a problem here. :dunno
Please advise.


Sub GenerateSelectedSQL()
Dim N As Integer
Dim stat1, stat2 As String
Dim i, r, x, y, z As Integer
Dim s As Double
Dim sPath As String
Dim fName, fPath, strPath As String
Dim str1, str2 As String
Dim fs, a
Application.DisplayAlerts = False 'disable confirm replace file dialog box
x = 1
y = 1
z = 1
i = 1
Sheets(2).Activate
r = Sheets("Sheet1").Range("C:C").CurrentRegion.Rows.Count
strPath = ThisWorkbook.Path & Application.PathSeparator & "Scripts"
Dim fSlash As String, dAddy As String
fSlash = Application.PathSeparator
dAddy = ThisWorkbook.Path & Application.PathSeparator
On Error Resume Next
MkDir dAddy & "Scripts"
If Err <> 0 Then
'The folder already exists
Else
MkDir strPath 'There was no folder so it was created
End If
On Error GoTo 0
If (strRetDate = vbNullString) Then
strRetDate = Format(Now, "yyyy-mm-dd hh:mm")
MsgBox "Date/Time Set : " & strRetDate
End If
With UserForm1.ListBox1
For i = 1 To .ListCount
Next i
End With
Sheets(2).Select
Sheets(2).Name = "Sheet2"
Sheets(2).Cells(1, 1).Value = vbNullString
Sheets(2).Cells(2, 1).Value = vbNullString
Sheets(1).Select
Application.DisplayAlerts = True
Application.StatusBar = vbNullString
ShowProgressBar
End Sub


I would like to match the string in the listbox with the string in the column C row i. If the string is same, then I would want to copy the data for the whole row. How can I do it?

[Killian]

Having set the range to apply it to, you can use the find method


Set rngColC = Sheets("Sheet1").Range("C:C").CurrentRegion
With ListBox1
For i = 0 To .ListCount - 1 ' first listbox index is 0!
Set rngResult = rngColC.Find(What:=ListBox1.List(i, 0), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not rngResult Is Nothing Then
'copy row and paste it somewhere
rngResult.EntireRow.Copy Destination:=Worksheets("Sheet2").Cells(i + 1, 1)
End If
Next i
End With

If you might have more than one match, you'll need to extend each search with a FindNext

[sheeeng]

How do you implement the FindNext? :doh: Sorry, I'm a bit inexperience in VBA.

My code as below.



Sub GenerateSelectedSQL()
Dim N As Integer
Dim stat1, stat2 As String
Dim I, r, X, y, z As Integer
Dim S As Double
Dim sPath As String
Dim fName, fPath, strPath As String
Dim str1, str2 As String
Dim rngResult, fs, a As Variant
Dim rngColC As Range
Application.DisplayAlerts = False 'disable confirm replace file dialog box
X = 1
y = 1
z = 1
I = 1
Sheets(2).Activate
r = Sheets("Sheet1").Range("C:C").CurrentRegion.Rows.Count
strPath = ThisWorkbook.Path & Application.PathSeparator & "Scripts"
Dim fSlash As String, dAddy As String
fSlash = Application.PathSeparator
dAddy = ThisWorkbook.Path & Application.PathSeparator
On Error Resume Next
MkDir dAddy & "Scripts"
If Err <> 0 Then
'The folder already exists
Else
MkDir strPath 'There was no folder so it was created
End If
On Error GoTo 0
If (strRetDate = vbNullString) Then
strRetDate = Format(Now, "yyyy-mm-dd hh:mm")
MsgBox "Date/Time Set : " & strRetDate
End If
Set rngColC = Sheets("Sheet1").Range("C:C").CurrentRegion
With UserForm1.ListBox1
For I = 0 To .ListCount - 1 ' first listbox index is 0!
Set rngResult = rngColC.Find(What:=.List(I, 0), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not rngResult Is Nothing Then
'copy row and paste it somewhere
rngResult.EntireRow.Copy Destination:=Worksheets("Sheet2").Cells(I + 1, 1)
End If
Next I
End With
Sheets(2).Select
Sheets(2).Name = "Sheet2"
Sheets(2).Cells(1, 1).Value = vbNullString
Sheets(2).Cells(2, 1).Value = vbNullString
strRetDate = vbNullString
Sheets(1).Select
Application.DisplayAlerts = True
Application.StatusBar = vbNullString
ShowProgressBar
End Sub


Why it will copy the entire ListBox with its value in the Excel row to Sheet2?
Is my code written with bugs?

Thanks for helping... :friends: :hi:

[Killian]

So here's the listbox code adapted to find all the matches


Dim rngColC As Range
Dim strFirstAddress As String
Dim rngNextResult As Range
Dim rngNextSearch As Range
Dim i As Long
Dim c As Long
Set rngColC = Sheets("Sheet1").Range("C:C").CurrentRegion
With UserForm1.ListBox1
For i = 0 To .ListCount - 1 ' first listbox index is 0!
Set rngNextResult = rngColC.Find(What:=ListBox1.List(i, 0), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not rngNextResult Is Nothing Then
'copy row and paste it somewhere
rngNextResult.EntireRow.Copy Destination:=Worksheets("Sheet2").Cells(rngNextResult.Row, 1)
End If
'now if there's a match, find any others
If Not rngNextResult Is Nothing Then
Do 'change the search range to the remainder of the range
Set rngNextSearch = Range(rngNextResult, rngColC.End(xlDown))
Set rngNextResult = rngNextSearch.FindNext(rngNextResult)
strFirstAddress = rngNextResult.Address
If Not rngNextResult Is Nothing Then
rngNextResult.EntireRow.Copy Destination:=Worksheets("Sheet2").Cells(rngNextResult.Row, 1)
End If
Loop While Not rngNextResult Is Nothing And rngNextResult.Address <> strFirstAddress
End If
Next i

It copies the row to sheet 2 because tht's what I've told it to do with the example code


rngNextResult.EntireRow.Copy Destination:=Worksheets("Sheet2").Cells(rngNextResult.Row, 1)

You can replace this line with what you want to do with the result of each find. I know you said "I would want to copy the data for the whole row" but you need to specify what you want to do with it... copy it to where?

[sheeeng]

:hi: Thanks, Killian. :thumb You always being very helpful person. I appreciate your help. Btw, the code below (that you gave), I have tested it. :doh:

Working, but not the way that I think it should work. It looks like it is copy the whole sheet 1 to sheet 2. No difference btw them both.

The match string part is problematic to me. :banghead:
Anyone can clarify? :friends:

[sheeeng]

:hi: Thanks, Killian. :thumb You always being very helpful person. I appreciate your help. Btw, the code below (that you gave), I have tested it. :doh:



Sub GenSelectedSQL()

Dim rngColC As Range
Dim strFirstAddress As String
Dim rngNextResult As Range
Dim rngNextSearch As Range
Dim i As Long
Dim c As Long
Set rngColC = Sheets("Sheet1").Range("C:C").CurrentRegion
With UserForm1.ListBox1
For i = 0 To .ListCount - 1 ' first listbox index is 0!
Set rngNextResult = rngColC.Find(What:=ListBox1.List(i, 0), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not rngNextResult Is Nothing Then
'copy row and paste it somewhere
rngNextResult.EntireRow.Copy Destination:=Worksheets("Sheet2").Cells(rngNextResult.Row, 1)
End If
'now if there's a match, find any others
If Not rngNextResult Is Nothing Then
Do 'change the search range to the remainder of the range
Set rngNextSearch = Range(rngNextResult, rngColC.End(xlDown))
Set rngNextResult = rngNextSearch.FindNext(rngNextResult)
strFirstAddress = rngNextResult.Address
If Not rngNextResult Is Nothing Then
rngNextResult.EntireRow.Copy Destination:=Worksheets("Sheet2").Cells(rngNextResult.Row, 1)
End If
Loop While Not rngNextResult Is Nothing And rngNextResult.Address <> strFirstAddress
End If
Next i
End With
End Sub

Working, but not the way that I think it should work. It looks like it is copy the whole sheet 1 to sheet 2. No difference btw them both.

The match string part is problematic to me. :banghead:
Anyone can clarify? :friends:

[Killian]

It seems to work fine for me but you might want to try a different approach, which is a little easier to follow (but less efficient when the number of cells gets high)


Sub GenSelectedSQL2()
Dim rngColC As Range
Dim i As Long
Dim c As Range
Set rngColC = Sheets("Sheet1").Range("C:C").CurrentRegion
With UserForm1.ListBox1
For i = 0 To .ListCount - 1
For Each c In rngColC
If c.Value = .List(i, 0) Then
c.EntireRow.Copy Destination:=Worksheets("Sheet2").Cells(c.Row, 1)
End If
Next
Next
End With
End Sub

It's worth pointing out that using a loop is much slower than the Find/FindNext method

[sheeeng]

Thanks a lot.