I have written the following code; both Sheet 1 and Sheet 2 are rather big sheet with lots of data. Run this Macro is extremely time comsuming ( It has a high complexity I guess). I'm quite new at VBA and therefore having trouble make the code more effective.
Sub Find()
Dim rgFound As Range
Dim Index As Long: Index = 6
Dim Row as Long
Do While Worksheets("Sheet2").Cells(Index, "D").Value > 0
Sheets("Sheet1").Select
Set rgFound = Range("A1:A20000").Find(Worksheets("Sheet2").Cells(Index, "D").Value)
If Not rgFound Is Nothing Then
Row = rgFound.Row
Worksheets("Sheet1").Range("E" & Row).Value = Worksheets("Sheet2").Range("AA" & Index).Value
Worksheets("Sheet1").Range("F" & Row).Value = Worksheets("Sheet2").Range("AB" & Index).Value
Worksheets("Sheet1").Range("G" & Row).Value = Worksheets("Sheet2").Range("AC" & Index).Value
Worksheets("Sheet1").Range("H" & Row).Value = Worksheets("Sheet2").Range("Z" & Index).Value
Worksheets("Sheet1").Range("J" & Row).Value = Worksheets("Sheet2").Range("AG" & Index).Value
Worksheets("Sheet1").Range("I" & Row).Value = Worksheets("Sheet2").Range("AD" & Index).Value
Else
' Function // Not done yet
End If
Index = Index + 1
Loop
End Sub
Is the built in Find function effective? The loop loops trough roughly 250-400 values. Any Ideas?
Related
I have a loop looking for text in a column (that is working) and I want to post the result in a MsgBox, but when I use the msgbox in or outside the loop I will get a msgbox for every result found or only one msgbox with one result. What I would like is to make it post every result in 1 msgbox with a line break after each result.
I know the first code is not the prettiest or best way to go around finding duplicates and I should use an array for it, but it's the only way I got it to work.
The first code finding duplicates (not relevant for the question):
Dim lastRow As Long
Dim i As Long
Dim ws As Worksheet
Dim txt As String
Set ws = Sheets("Player List")
Dim matchFoundIndex As Long
Dim iCntr As Long
lastRow = Range("A201").End(xlUp).Row
For iCntr = 1 To lastRow
If Cells(iCntr, 1) <> "" Then
matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range("A1:A" &
lastRow), 0)
If iCntr <> matchFoundIndex Then
Cells(iCntr, 2) = "Duplicate"
End If
End If
Next
The loop with the msgbox:
For i = 2 To 201
If ws.Range("B" & i).Value = "Duplicate" Then
txt = "Duplicates found for" + " " + ws.Range("A" & i).Value + " " + "in" +
ws.Range("L" & i).Value + vbNewLine
End If
Next i
MsgBox txt
You need to persist the old value of txt.
txt = txt & "Duplicates found for" & " " & ws.Range("A" & i).Value & " " & "in" & ws.Range("L" & i).Value & vbNewLine
I have 2 worksheets in the same workbook. If a cell in SourceSheet meets certain criteria, I want to copy several non-adjacent cells in the same row to NewSheet. The problem is that it's taking over a half second to paste each and every cell, making the macro far too slow. The code below takes 8 seconds to complete a single loop. Is there a faster way I could do this?
Dim EnrollmentChanges As Range
Dim course1 As Range
Dim course1status As Range
Dim row As Long
Dim lrow As Long
Dim NewSheetRow As Long
'This is a dynamic named range
Set EnrollmentChanges = Sheets("SourceSheet").Range("Source")
NewSheetRow = 0
lrow = Sheets("SourceSheet").Range("A1").End(xlDown).row
For row = 2 To lrow
With EnrollmentChanges
course1 = Sheets("SourceSheet").Range("A" & row)
If course1 <> "" Then
course1status = Sheets("SourceSheet").Range("BS" & row)
If InStr(1, course1, "APEX") And course1status = "1" Then
NewSheetRow = NewSheetRow + 1
Sheets("NewSheet").Range("A" & NewSheetRow) = NewSheetRow
Sheets("NewSheet").Range("B" & NewSheetRow) = "W"
Sheets("NewSheet").Range("C" & NewSheetRow) = "S"
Sheets("NewSheet").Range("D" & NewSheetRow) = "MySchool"
Sheets("SourceSheet").Range("B" & row).Copy Sheets("NewSheet").Range("G" & NewSheetRow)
Sheets("SourceSheet").Range("W" & row).Copy Sheets("NewSheet").Range("H" & NewSheetRow)
Sheets("SourceSheet").Range("V" & row).Copy Sheets("NewSheet").Range("J" & NewSheetRow)
Sheets("SourceSheet").Range("Y" & row).Copy Sheets("NewSheet").Range("K" & NewSheetRow)
Sheets("NewSheet").Range("L" & NewSheetRow) = "OR"
Sheets("SourceSheet").Range("B" & row).Copy Sheets("NewSheet").Range("M" & NewSheetRow)
Sheets("SourceSheet").Range("A" & row).Copy Sheets("NewSheet").Range("P" & NewSheetRow)
End If
Else: GoTo NextRow
End If
End With
NextRow:
Next
The best way to approach this would to be avoiding copy and paste altogether (which are notoriously slow). The only time that copy/paste MAY be worth keeping is when you need to copy formatting. If you just need the values then you can do something like this:
Dim EnrollmentChanges As Range
Dim course1 As Range
Dim course1status As Range
Dim row As Long
Dim lrow As Long
Dim NewSheetRow As Long
'This is a dynamic named range
Set EnrollmentChanges = Sheets("SourceSheet").Range("Source")
NewSheetRow = 0
lrow = Sheets("SourceSheet").Range("A1").End(xlDown).row
For row = 2 To lrow
With EnrollmentChanges
course1 = Sheets("SourceSheet").Range("A" & row)
If course1 <> "" Then
course1status = Sheets("SourceSheet").Range("BS" & row)
If InStr(1, course1, "APEX") And course1status = "1" Then
NewSheetRow = NewSheetRow + 1
With Sheets("NewSheet")
.Range("A" & NewSheetRow).Value = NewSheetRow
.Range("B" & NewSheetRow).Value = "W"
.Range("C" & NewSheetRow).Value = "S"
.Range("D" & NewSheetRow).Value = "MySchool"
.Range("G" & NewSheetRow.Value = Sheets("SourceSheet").Range("B" & row).Value
.Range("H" & NewSheetRow).Value = Sheets("SourceSheet").Range("W" & row).Value
.Range("J" & NewSheetRow).Value = Sheets("SourceSheet").Range("V" & row).Value
.Range("K" & NewSheetRow).Value = Sheets("SourceSheet").Range("Y" & row).Value
.Range("L" & NewSheetRow).Value = "OR"
.Range("M" & NewSheetRow).Value = Sheets("SourceSheet").Range("B" & row).Value
.Range("P" & NewSheetRow).Value = Sheets("SourceSheet").Range("A" & row).Value
End With
End If
' No need for this since you are skipping the operation using the if block
' GoTo is messy and should be avoided where possible as well.
'Else: GoTo NextRow
End If
End With
NextRow:
Next
All I did was swap the order and assign the value directly based on the value retrieved versus storing the value retrieved as a copy, and putting it in a new location. Once you practice this a bit it will make much more sense (and it will speed up your code considerably).
As noted at the beginning, if you need formatting kept then that is a bit different.
Also, I didnt bother with optimizing or indenting any of the other elements of your code, but you will want to clean it up with proper indenting and skipping things like "GoTo".
call this sub a the top of you macro:
Sub MakeItFaster()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
ActiveSheet.DisplayPageBreaks = False
End Sub
I'm trying to create a Macro that will modify contents in columns S, W and AH based on the content in AB
e.g. if AB1 = No, then S1=C-MEM, AH = N/A and W is cleared.
For some reason, I get a 'Type mismatch' error on the first line of my if statement and can't figure out why or how to fix it - even after reading other posts about similar issue.
Sub test()
Dim lastrow As Long
Dim i As Long
lastrow = Range("AB" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
**-> If Range("AB" & i).Value = "No" Then
Range("S" & i).Value = "C-MEM"
Range("W" & i).Value = ""
Range("AH" & i).Value = "N/A"
End If
Next i
End Sub
Thanks
You are trying to test if an error is = No.
Test for the error and skip the logic in that loop:
Sub test()
Dim lastrow As Long
Dim i As Long
lastrow = Range("AB" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Not IsError(Range("AB" & i).Value) Then
If Range("AB" & i).Value = "No" Then
Range("S" & i).Value = "C-MEM"
Range("W" & i).Value = ""
Range("AH" & i).Value = "N/A"
End If
End If
Next i
End Sub
I want to create a macro that check all the cells of a column and if the first two characters of a cell is "BB" then i want the macro to extract three characters from the cell and paste it to the next column but a the corresponding row.
But my formula after the if clause is not working.
this is what i have done since:
Sub test()
Dim lmid As String
Dim srange, SelData, ExtBbFor As String
Dim lastrow As Long
Dim i, icount As Integer
lastrow = ActiveSheet.Range("B30000").End(xlUp).Row
srange = "G1:G" & lastrow
SelData = "A1:G" & lastrow
Range(srange).Formula = "=mid(E1,1,3)"
For i = 1 To lastrow
If InStr(1, LCase(Range("E" & i)), "bb") <> 0 Then
Range("G" & i).Formula = "=mid("E & i", 4, 3)"
End If
Next i
End Sub
thanks in advance
Try with below. It will work
Range("G" & i).Value = Mid(Range("E" & i), 4, 3)
If the cell is not limited to 7 then you need as below
Range("G" & i).Value = "=Mid(E" & i & ", 3, " & Len(E & "& i & ") & ")"
It will extract from the 3rd character up to the last character in a cell.
Your syntax is wrong where you're trying to concatenate strings, I think you mean to use:
Range("G" & i).Formula = "=MID(E" & i & ",4,3)"
Based on your code I think this will do the exact same thing without having to loop or declare any variables:
Sub test()
With Range("G1:G" & Cells(Rows.Count, 2).End(xlUp).Row)
.FormulaR1C1 = "=IF(UPPER(LEFT(RC[-2],2))=""BB"",MID(RC[-2],4,3),"""")"
.Value = .Value
End With
End Sub
I am new to VBA programming, and I am looking for a way to search a range of about 2,000 to 3,000 rows to compare quantities where ID numbers match, and generate a message box displaying the ID number if there are any matching ID numbers where quantities do not match. There are 2 matching ID numbers in the data.
I have found and adapted this code
`Dim rng1 As Range, rng2 As Range, rngName As Range, i As Integer, j As Integer
For i = 1 To Sheets("Sheet1 (2)").Range("q" & Rows.Count).End(xlUp).Row
Set rng1 = Sheets("Sheet1 (2)").Range("q" & i)
For j = 1 To Sheets("Sheet1 (2)").Range("q" & Rows.Count).End(xlUp).Row
Set rng2 = Sheets("Sheet1 (2)").Range("q" & j)
Set rngName = Sheets("Sheet1 (2)").Range("q" & j)
If rng1.Value = rng2.Value Then
If rng1.Offset(0, 2).Value <> rng2.Offset(0, 2).Value Then
MsgBox ("Not equal " & rng1 & " Net " & rng1.Offset(0, 2) - rng2.Offset(0, 2))
Exit For
End If
End If
Set rng2 = Nothing
Next j
Set rng1 = Nothing
Next i`
Honestly, this is beyond my current skill level in VBA, and I can't think of any way to use the Macro recorder to help. I want to know if there is any way to optimize this code to run faster, and also if there is a way to adapt it to write out all ID numbers with the amount of variance, instead of displaying the message box for each ID number individually.
Thanks!
If the data is sorted (assumes ID in column Q, quantity in Column R):
Dim ErrorList as String
With Sheets("Sheet1 (2)")
For i = 1 To .Range("q" & Rows.Count).End(xlUp).Row step 2
if .range("R" & i).value <> .range("R" & i+1) then
ErrorList = ErrorList & "ID: " & .range("Q" & I) & " Net: " & _
.range("R" & i).value - .range("R" & i+1).value & vbcrlf
end if
next
end with
'do something like MsgBox with ErrorList
If the data is NOT sorted (same column assumptions):
Dim ErrorList as String
With Sheets("Sheet1 (2)")
For i = 1 To .Range("q" & Rows.Count).End(xlUp).Row
'assume .range("q"
Set Rng = .Range("q:q").Find(what:=.range("q" & i), LookIn:=xlValues, _
lookat:=xlPart, MatchCase:=False)
If .range("Q" & I).value <> rng.cells(1,1).value then
ErrorList = ErrorList & "ID: " & .range("Q" & I) & " Net: " & _
.range("R" & i).value - .range("R" & i+1).value & vbcrlf
end if
next
end with
'do something like MsgBox with ErrorList
The .Find is MUCH quicker than an inner loop through all the rows of data again (someone a week or so ago tested and found something along the lines of 1000x times faster than a loop). Unfortunately, this method will leave you with duplicate IDs in your mismatch list, since it will run through the whole list, finding each of the pairs and discovering that they both don't match:
ID Value
ABC 1
BCD 6
ABC 2
It will loop to ABC/1, find ABC/2, then later in the loop find ABC/2 and discover that it doesn't match ABC/1, and report on both. The sorted data in the first option will work better if you can get your data sorted.
NOTE: No code was tested in the writing of this answer. There may be typos to resolve
You can do this with a formula if there can be at most only two matches: eg if ID is in ColA and Amount in ColB then in ColC enter
=IFERROR(VLOOKUP(A2,A3:B$9,2,FALSE)-B2,0)
and fill down. Result will be zero if no mismatch (or no matching Id), otherwise will be the difference between the two amounts.