I have the following VBA code that counts how many rows there are in a table and then extracts data from every other row (spreadsheet A). I have another spreadsheet (spreadsheet B) that grabs data from the output of this code using Match and Indirect formulas. When I run the code with only spreadsheet A open it runs very fast. If I have spreadsheet B open while I run the code in spreadsheet A it runs a lot slower, I'm guessing because it's trying to grab data while the code is running. Is there a way I can have the code run and stop the other spreadsheet from accessing the data until the code is finished? It's inconvenient to close spreadsheet B every time i need to run the code.
Sub GetTopForces()
Application.ScreenUpdating = False
Dim i, j, count, cell As Integer
count = 0
cell = 1
i = 0
j = 0
' get count
Do While cell <> 0
cell = Cells(count + 4, 1).Value
count = count + 1
Loop
' get forces on top of column only
Do While i < count
Cells(4 + i, 16).Value = Cells(5 + j, 1).Value
Cells(4 + i, 17).Value = Cells(5 + j, 2).Value
Cells(4 + i, 18).Value = Cells(5 + j, 3).Value
Cells(4 + i, 19).Value = -1 * Cells(5 + j, 5).Value
Cells(4 + i, 20).Value = Cells(5 + j, 9).Value
Cells(4 + i, 21).Value = Cells(5 + j, 10).Value
i = i + 1
j = j + 2
Loop
Application.ScreenUpdating = True
End Sub
My knowledge in VBA is basic so I appreciate any advice. Thank you :)
Related
I am working on a workbook that has three tabs. My Customer list Addresses, Outsource customer listing addresses: and Output No Match:. I am looking to run my list agents an outsource list and if my address list does not match any addresses on the out source list. It outputs on the No match tab.
I have built a working document but it is so slow and feel someone here could really help point me in the right direction.
All three sheets column headers ("Customer Name","Address 1","Address 2","City","State","Zip Code")
I am using a code similar to the one below to find none matches on all the columns. It only looks at the first few characters in hope to speed things up but i am getting no where fast.
I am running it on a loop somewhat like this which seems to be very incessant and slow when comparing addresses agent 200,000 records.
For I = 2 To LastRow
If Left(UCase(Trim(wsAddressS_1.Cells(1 + I, 6).Value)), 5) =
Left(UCase(VLookLike(wsAddressS_1.Cells(1 + I, 6).Value, wsAddressS_2.Range("F1:F" & LastRow2 + 10))), 5) Then
Match_Zip = "Match"
Else
Match_Zip = "No Match"
End If
If strMatchZip <> "Match" Then
LastRow1 = wsAddressS_4.Range("F" & Rows.Count).End(xlUp).Row
wsAddressS_4.Cells(LastRow4 + 1, 1).Value = wsAddressS_1.Cells(1 + I, 1).Value
wsAddressS_4.Cells(LastRow4 + 1, 2).Value = wsAddressS_1.Cells(1 + I, 2).Value
wsAddressS_4.Cells(LastRow4 + 1, 3).Value = wsAddressS_1.Cells(1 + I, 3).Value
wsAddressS_4.Cells(LastRow4 + 1, 4).Value = wsAddressS_1.Cells(1 + I, 4).Value
wsAddressS_4.Cells(LastRow4 + 1, 5).Value = wsAddressS_1.Cells(1 + I, 5).Value
wsAddressS_4.Cells(LastRow4 + 1, 6).Value = wsAddressS_1.Cells(1 + I, 6).Value
End If
Sleep 10
DoEvents
Next I
e.g VLookLike
Private Function VLookLike(txt As String, rng As Range) As String
Dim temp As String, e, n As Long, a()
Static RegX As Object
If RegX Is Nothing Then
Set RegX = CreateObject("VBScript.RegExp")
With RegX
.Global = True
.IgnoreCase = True
.Pattern = "(\S+).*" & Chr(2) & ".*\1"
End With
End If
With RegX
For Each e In rng.Value
If UCase$(e) = UCase(txt) Then
VLookLike = e
Exit For
End If
temp = Join$(Array(e, txt), Chr(2))
If .test(temp) Then
n = n + 1
ReDim Preserve a(1 To 2, 1 To n)
a(2, n) = e
Do While .test(temp)
a(1, n) = a(1, n) + Len(.Execute(temp)(0).submatches(0))
temp = Replace(temp, .Execute(temp)(0).submatches(0), "")
Loop
End If
Next
End With
If (VLookLike = "") * (n > 0) Then
With Application
VLookLike = .HLookup(.Max(.Index(a, 1, 0)), a, 2, False)
End With
End If
End Function
Any help or suggestions would be much appreciated!
I haven't read all the code, sorry, but I have had problems on comparing strings. Perhaps it would work if you tell vba that you are gonna compare 2 strings. You could use the function Cstr() for example
CStr(Left(UCase(StrAddress), 3)) = CStr(Left(UCase(VLookLike(StrAddress, rng2)), 3))
how to copy a range of cells(N cells) from a column in one sheet and paste it, with a blank cell inserted after every 7(n cells), to another sheet?
Ex: Given image below
I think it's a pretty easy task and you are making it sound difficult. Here's the code to help you out.
Sub do_something()
last_row = ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).End(xlDown).Row
j = 1
For i = 1 To last_row
If i Mod 8 = 0 Then
j = j + 1
End If
Cells(j, 2).Value = Cells(i, 1).Value
j = j + 1
Next i
End Sub
And as you mentioned in your comment, below code will satisfy your need.
Sub do_something2()
last_row = ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).End(xlDown).Row
j = 1
i = 1
Do While i <= last_row
Worksheets("Sheet2").Range(Worksheets("Sheet2").Cells(j, 1),
Worksheets("Sheet2").Cells(j + 6, 1)).Value = _
Worksheets("Sheet1").Range(Worksheets("Sheet1").Cells(i, 1),
Worksheets("Sheet1").Cells(i + 6, 1)).Value
j = j + 8
i = i + 7
Loop
End Sub
I am trying to edit some VBA code which currently loops until a certain test is met. What I would like to do is loop until two conditions are met. I am having trouble getting it do so. Here is the original code, which works.
Loop
For j = 1 To 29
Increment = Worksheets("Price & Energy Curve").Cells(8 + Start + j, 3).Value
l = Int((Worksheets("Capacity").Cells(57 + j, 12).Value) * (-1) / Increment)
k = WorksheetFunction.Max((l + 1) * Increment, 0)
Worksheets("Capacity").Activate
ActiveSheet.Cells(56 + j, 17).Value = k
test = ActiveSheet.Cells(57 + j, 13).Value
Do While test <> True
k = k + Increment
ActiveSheet.Cells(56 + j, 17).Value = k
test = ActiveSheet.Cells(57 + j, 13).Value
Loop
Next j
I would like to add the additional test of
test = ActiveSheet.Cells(57 + j, 37).Value
So that when
test = ActiveSheet.Cells(57 + j, 13).Value
and
test = ActiveSheet.Cells(57 + j, 37).Value
are true, the loop exits.
Check this loop
Do While test1 <> True Or test2 <> True
k = k + Increment
ActiveSheet.Cells(56 + j, 17).Value = k
test1 = ActiveSheet.Cells(57 + j, 13).Value
test2 = ActiveSheet.Cells(57 + j, 37).Value
Loop
For the first time I've worked in Excel VBA to find rows in my dataset that contain the same adress as another entry in a cluster. These entries have to be merged and the row then is deleted. I've come up with the following, which works (As far as I can tell from the testing I did on small samples of the set):
Sub Merge_Orders()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Dim lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Dim y As Long
Dim x As Long
Dim j As Long
Dim k As Long
For i = 2 To lastrow //for each row, starting below header row
j = 1
y = (Cells(i, 9)) //this is the clusternumber
Do While y = (Cells(i + j, 9)) //while the next row is in the same cluster
x = (Cells(i, 12)) //this is the adresscode
k = 1
Do While x = (Cells(i + k, 12)) //while the current adresscode is the same as the next, iterating until another adresscode is hit
Cells(i, 16) = Val(Cells(i, 16)) + Val(Cells(i + k, 16)) //update cell value
Cells(i, 18) = Cells(i, 18) + Cells(i + k, 18) //update cell value
Cells(i, 19) = Cells(i, 19) + Cells(i + k, 19) //update cell value
If Cells(i, 20) > Cells(i + k, 20) Then
Cells(i, 20) = Cells(i + k, 20) //update cell value
End If
If Cells(i, 21) > Cells(i + k, 21) Then
Cells(i, 21) = Cells(i + k, 21) //update cell value
End If
Cells(i, 22) = Cells(i, 22) + Cells(i + k, 22) //update cell value
Cells(i, 23) = Cells(i, 23) + Cells(i + k, 23) //update cell value
Rows(i + 1).EntireRow.Delete //Delete the row from which data was pulled
k = k + 1
Loop
j = j + 1
Loop
Next i
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub
The problem I'm facing is time. Testing this on a small sample of ~50 rows took over 5 minutes. My entries total over 100K rows. It's been running for over a day with no end in sight. Is there a way to optimize this so I don't have to wait until I'm grey?
Kind regards,
Rob
Two things as I mentioned in the comments:
1) Remove k (and the entire k=k+1 line); replace with j. Also replace your Rows(i + 1).EntireRow.Delete with Rows(i + j).EntireRow.Delete.
2) Since you are deleting rows, lastrow is actually blank by the time you get there. Instead of i=2 to lastrow, make it do while Cells(i,12)<>"" or something. This is causing it to loop over a bunch of rows that are empty.
Also, you can do these type of rollups much easier with a PivotTable, or, as mentioned in the comments, with an SQL GROUP BY.
Here is a reference image of my worksheet so that everyone can see the format.
http://imgur.com/a/dacIB
The purpose of this is to sort data that matches into columns. The criteria that I'm looking for is on the right and the database data that i'm looking through is on the left. Here is my code for the loop.
Dim i As Long
Dim Counter As Long
Dim WS_Count As Long
Dim k As Long
WS_Count = Worksheets.Count
For k = 4 To WS_Count
With Worksheets(k)
For Counter = 0 To ActiveSheet.Rows(1).Cells.Find("QQQ").Offset(0, -1) - 1
For i = 0 To ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row - 2
If Cells(2 + i, 5).Value = Rows(i + 2).Cells.Find("QQQ").Offset(0, 1) And _
Cells(2 + i, 2).Value = Rows(i + 2).Cells.Find("QQQ").Offset(0, 3) And _
Cells(2 + i, 1).Value = Rows(i + 2).Cells.Find("QQQ").Offset(0, 2) Then
Cells(2 + i, Counter + 7).Value = Cells(2 + i, 4).Value
End If
Next i
Next Counter
End With
Next k
I need to get the Value in column D into columns associated with the criteria on the right. Columns G:O, numbered 1-9, match the column T numbers, 1-9.
I can't for the life of me figure out why, in Row 4, that it made 0's all the way across. It should go in this order all the rows in the first column > all the rows in the second column > ... > next sheet. If anything is unclear please let me know.
Edit: So my Counter and i Longs were slightly off so I made some adjustments. They should be right, but my code still isn't executing correctly. It is not seeing the matches it should. My If Then must be messed up some how.
Dim i As Long
Dim Counter As Long
Dim WS_Count As Long
Dim k As Long
WS_Count = Worksheets.Count
For k = 4 To WS_Count
With Worksheets(k)
For Counter = 0 To .Rows(1).Cells.Find("QQQ").Offset(0, -1).Value - 1
For i = 0 To .Range("A" & .Rows.Count).End(xlUp).Row - 2
If .Cells(2 + i, 5).Value = .Rows(Counter + 2).Cells.Find("QQQ").Offset(0, 1) And _
.Cells(2 + i, 2).Value = .Rows(Counter + 2).Cells.Find("QQQ").Offset(0, 3) And _
.Cells(2 + i, 1).Value = .Rows(Counter + 2).Cells.Find("QQQ").Offset(0, 2) Then
.Cells(2 + i, Counter + 7).Value = .Cells(2 + i, 4).Value
End If
Next i
Next Counter
End With
Next k
Okay, so it works now. I think it was having a really hard time figuring out what sheet to pull the statements from. Notice the .Cells(..... That period made the Cells defined to the ActiveSheet. I also changed .Rows(i+2)... to .Rows(Counter+2) The criteria cell location would shift down with each new imaking it impossible for there to be a match. The one in the screenshot just happened to be coincidence. Thanks, hope this helps someone in the future.