I have an excel file which has two sheets where Sheet 1 has 5k records and Sheet 2 has 170k records. I am trying to perform a VLOOKUP in Sheet 2 (based on the values from column A). On top the value returned by the vlookup I am trying to to verify a few conditions to create a flag (Pass/Fail/Not Available/Not Applicable)
Here's the code that I have tried so far:
Public Sub Validation()
With Workbooks("Macro.xlsm").Worksheets(1)
maxrows = .Cells(Rows.Count, 1).End(xlUp).Row
maxCols = .Cells(1, Columns.Count).End(xlToLeft).Column
Data = .Range(.Cells(1, 1), .Cells(maxrows, maxCols))
End With
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Workbooks("Macro.xlsm").Worksheets(2).Activate
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
cellvalue = Range("A" & i).Value
'Logic for V1
RES_V1 = Application.VLookup(cellvalue, Data, 2, 0)
If IsError(RES_V1) Then
V1 = "Not Available"
ElseIf UCase(RES_V1) Like "30 DAYS*" Or UCase(RES_V1) Like "60 DAYS*" Or UCase(RES_V1) = "NO SA" Then
V1 = "Pass"
ElseIf UCase(RES_V1) = "NOT APPLICABLE" Then
V1 = "Not Applicable"
Else
V1 = "Fail"
End If
Cells(i, "B").Value = V1
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
This process is taking too long to execute and most of the times the excel either crashes or does not respond. I have tried using the basic "With" statement and applying this logic. In addition I have also tried turning the For loop into For Each thinking that it might be faster. Neither of these helped. Any suggestions with regards to re-writing the code or tweaking the existing code to fix the issue alongside improve the performance is highly appreciated.
Related
Some background: Each month I build a pivot table that has approx 30 or so business units (along the y axis) - lets call them groups. Each group has a number of GL accounts that change month to month. For example, Group 14 might have 10 GL accounts one month than the next have only 3. For each group, we need the summation of the totals for the GL accounts (that start with PL203000 & PL211010) for each group. Before we had to total these GL accounts for each group by hand. This has been solved with the code I have displayed below.
The code works perfectly when each group has more than one GL account (See pic 1)
The problem I am facing is when there is only one GL account, the code doesn't sum the correct amounts (see 2nd pic).
When digging into my code, you can see that it is summing the incorrect sections since i have a Rows.Count.End(xlUp) establishing the range. If there is only one GL account, it skips to the next section thereby establishing an incorrect formula
Perhaps my code needs to be completely revamped in order to account for groups where there is only one GL account to sum? If so, what sort of if statement can i code where it ignores groups that have only one GL account?
If not, than is the solution to have VBA count the range and if it is less than 3, ignore group and move on to the next?
'this section spits out the values needed to sum
For i = nRowMax To 4 Step -1
If Left(Cells(i, 1), 8) = "PL211010" Or Left(Cells(i, 1), 8) = "PL203000"
Then
Cells(i, 4).Copy
Cells(i, 5).PasteSpecial xlPasteValues
Range(Cells(i, 1), Cells(i, 4)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next i
Application.CutCopyMode = False
'this section uses the values the first section specified to write the sum formula
'i believe the macro uses this section of code to write the first formula and the next section of code writes the formulas for the rest of the groups
Dim firstRow As Variant
Dim finalRow As Variant
finalRow = Range("E" & Rows.Count).End(xlUp).Row
firstRow = Cells(finalRow, 5).End(xlUp).Row
If IsNumeric(Cells(finalRow + 1, 5)) Then
Cells(firstRow, 6).Formula = "=SUM(D" & firstRow & ":D" & finalRow & ")"
End If
'this section goes through the whole sheet to sum each group
For y = firstRow To 5 Step -1
finalRow = Cells(y, 5).End(xlUp).Row
firstRow = Cells(finalRow, 5).End(xlUp).Row
If firstRow < 5 Then firstRow = 5
If IsNumeric(Cells(finalRow + 1, 5)) Then
Cells(firstRow, 6).Formula = "=SUM(D" & firstRow & ":D" & finalRow &")"
End If
y = firstRow
'If firstRow = 5 Then Exit Sub
Next y
If your dataset is an accurate enough example, you can scan through your business units and pick out only what you need. I have some example code here that will build up your sum range by using the Union function and applying that to the SUM formula when the entire business unit has been scanned. Of course, this is only an example that fits the data shown. You'll have to expand it to fit situations that are not visible to me.
To simplify the logic, I've separated the code into a function that will start scanning rows for a business unit and will stop when it reaches the end of the business unit -- the test I'm using for detecting the start of the next BU is a line that does not start with "PL". This may or may not be correct for all your data.
Because this code is checking each line and accumulating the sum range using the Union, if you only have one cell, you'll still get a formula that says =SUM($D$30) but it works.
Option Explicit
Sub test()
Dim dataArea As Range
Set dataArea = ActiveSheet.Range("A1")
Do While Not IsEmpty(dataArea.Cells(1, 1))
Set dataArea = AddSums(dataArea)
Loop
End Sub
Private Function AddSums(ByRef businessUnitStart As Range) As Range
'--- loops through cells following the 'Start' range given,
' and accumulates the range of accounts to summarize
' RETURNS the start of the next business unit range
Dim accountRow As Range
Dim account As String
Set accountRow = businessUnitStart.Offset(1, 0)
Dim sumArea As Range
Do While Left$(accountRow.Cells(1, 1).Value2, 2) = "PL"
account = accountRow.Cells(1, 1).Value2
If (Left$(account, 8) = "PL211010") Or (Left$(account, 8) = "PL203000") Then
'--- add this account to the sum formula
If sumArea Is Nothing Then
Set sumArea = accountRow.Cells(1, 4)
Else
Set sumArea = Union(sumArea, accountRow.Cells(1, 4))
End If
End If
Set accountRow = accountRow.Offset(1, 0)
Loop
If Not sumArea Is Nothing Then
Dim accountSum As Range
Set accountSum = businessUnitStart.Offset(1, 6)
accountSum.Formula = "=SUM(" & sumArea.Address & ")"
End If
Set AddSums = accountRow
End Function
I am reading through some VBA code written by someone else and I can't understand the logic behind it:
Sheets("IC View").Select
RowCount = Cells(Rows.Count, 1).End(xlUp).Row
If RowCount <= 9 Then GoTo skipNoChange
'Sheets("IC View").Select
Range("A1:BG1").EntireColumn.Hidden = False
Range(Cells(10, "A"), Cells(LastRowIC,
"BG")).SpecialCells(xlCellTypeVisible).Copy
Worksheets("IC Log").Select
nextRowLog = Cells(Rows.Count, 1).End(xlUp).Row + 1
Range("A" & nextRowLog).PasteSpecial xlPasteValues
Application.CutCopyMode = False
skipNoChange:
Sheets("IC View").Select
zeroCheck = 2 'start at column 3
Do While Cells(9, zeroCheck + 1).value <> "Checked_By"
If Cells(9, zeroCheck + 1).value = "" Then Columns(zeroCheck +
1).EntireColumn.Hidden = True
If Cells(9, zeroCheck + 1).value <> "" Then Columns(zeroCheck +
1).EntireColumn.Hidden = False
zeroCheck = zeroCheck + 1
Loop
'==================================
Call checkFreesaleChanges
So if the row count is less than or equal to 9 then i understand it needs to go 'SkipNoChange', but where does 'SkipNoChange end? Does it end at 'zeroCheck ... Loop' and then moves on to 'Call checkFreesaleChanges'?
What happens if the row count is greater than 9? Does it continue with the code but doesn't run the bit between 'skipNoChange: ...Loop' but does run CallcheckFreesaleChanges onwards?
Here is an example of a if then.... Else.... end if.
It makes the code easier to read and easier to follow in my opinion.
Adding comments to the else and end if rows means you don't need to scroll up and down to see what the else or end if is for.
Sheets("IC View").Select
RowCount = Cells(Rows.Count, 1).End(xlUp).Row
If RowCount > 9 Then
'Sheets("IC View").Select
Range("A1:BG1").EntireColumn.Hidden = False
Range(Cells(10, "A"), Cells(LastRowIC,
"BG")).SpecialCells(xlCellTypeVisible).Copy
Worksheets("IC Log").Select
nextRowLog = Cells(Rows.Count, 1).End(xlUp).Row + 1
Range("A" & nextRowLog).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Else ' rowcount is less than 9
msgbox "Rowcount is less than 9"
End If ' end of if rowcount syntax
Sheets("IC View").Select
zeroCheck = 2 'start at column 3
Do While Cells(9, zeroCheck + 1).value <> "Checked_By"
If Cells(9, zeroCheck + 1).value = "" Then Columns(zeroCheck +
1).EntireColumn.Hidden = True
If Cells(9, zeroCheck + 1).value <> "" Then Columns(zeroCheck +
1).EntireColumn.Hidden = False
zeroCheck = zeroCheck + 1
Loop
'==================================
Call checkFreesaleChanges
skipNoChange: is a label, a place holder. You can use any word ending thit a colon :
It's often used for error handling in VBA.
Sub DoSomething
on error goto hell
'some code here
....
Ciao:
exit Sub
hell:
msgbox "Shit happens"
resume Ciao
End Sub
GoTo Statement
Branches unconditionally to a specified line within a procedure.
Syntax GoTo line
The required line argument can be any line label or line number.
skipNoChange: is a line label as indicated by the fact it is completely to the left and the line ends with : and nothing after. Try and indent the label - it will move back to the left hand side of the code pane.
In your example:
If RowCount <= 9 Then GoTo skipNoChange
where RowCount is determined by Cells(Rows.Count, 1).End(xlUp).Row, you are saying if the last populated row in column A of the activesheet, determined by coming up from the bottom of the sheet, is <=9 then branch the code to the line label skipNoChange. This is a conditional transfer of control. The program control shifts to the line label. The lines between this conditional test and the label are not executed as this point. If code later loops back and the condition is not met then they may in future be executed. The program continues to execute from the label onwards. It pretty much is as on tin "GoTo".
To many GoTos make program flow hard to follow and read. Usually you can re-write to use a different control flow structure as shown in at least one of the other answers.
It's something of a relic from before structured programming really took off. Interesting reading here.
I am trying to write a code for filtering data with particular criteria and selecting filtered data, copy and pasting visible cells only in different sheet. However, I am getting error "Run time error 1004" stating MS Office excel can not create or use the data range because it is too complex.
enter image description here
below is the code that I am using
Set mwb = ActiveWorkbook
fname = ActiveWorkbook.Name
pth = path
period = Sheets("DEF").Range("F18").Value
ddate = Range("L6").Value
Sheets("MacroTOSplit").Select
blr = Range("C50").End(xlUp).Row
Rcfield = Range("C1").Value
For a = 4 To blr Step 1
Sheets("MacroTOSplit").Select
If Cells(a, "C").Value <> "" Then
rc1 = Cells(a, "C").Value
Sheets("XYZ").Select
Cells.AutoFilter
If lr >= 2 Then
Range("B2:B" & lr + 1).EntireRow.Delete
End If
Sheets("ABC").Select
dlr = lr
Set datarange = Sheets("ABC").Range(Cells(1, 1), Cells(dlr, "BG"))
'Filter for each unit and copy the data
datarange.AutoFilter Field:=Rcfield, Criteria1:=rc1, Operator:=xlFilterValues
datarange.Range(Cells(2, 1), Cells(dlr, "BG")).SpecialCells(xlCellTypeVisible).Copy Sheets("XYZ").Range("A2")
I am getting error at last step.
Please provide some solution for this.
Thanks,
Ravi
Try adjusting the last line to say:
datarange.Range(Cells(2, 1).address & ":" & Cells(dlr, "BG").address)
I think that you are out of luck if you get the range too complex message.
However, if it is possible, you could pre-sort your data so that the selection is in fewer non-contiguous blocks. This would make the selection less complex.
Please be aware that I am working with a series of ~1000 line medical information databases. Due to the size of the databases, manual manipulation of the data is too time consuming. As such, I have attempted to learn VBA and code an Excel 2010 macro using VBA to help me accomplish parsing certain data. The desired output is to split certain characters from a provided string on each line of the database as follows:
99204 - OFFICE/OUTPATIENT VISIT, NEW
will need to be split into
Active Row Active Column = 99204 ActiveRow Active Column+3 = OFFICE/OUTPATIENT VISIT, NEW
I have researched this topic using Walkenbach's "Excel 2013: Power Programming with VBA" and a fair amount of web resources, including this awesome site, but have been unable to develop a fully-workable solution using VBA in Excel. The code for my current macro is:
Sub EasySplit()
Dim text As String
Dim a As Integer
Dim name As Variant
text = ActiveCell.Value
name = Split(text, "-", 2)
For a = 0 To 1
Cells(1, a + 3).Value = Trim(name(a))
Next a
End Sub
The code uses the "-" character as a delimiter to split the input string into two substrings (I have limited the output strings to 2, as there exists in some input strings multiple "-" characters). I have trimmed the second string output to remove leading spaces.
The trouble that I am having is that the output is being presented at the top of the activesheet, instead of on the activerow.
Thank you in advance for any help. I have been working on this for 2 days and although I have made some progress, I feel that I have reached an impasse. I think that the issue is somewhere in the
Cells(1, a + 3).Value = Trim(name(a))
code, specifically with "Cells()".
Thank you Conrad Frix!
Yah.. funny enough. Just after I post I have a brainstorm.. and modify the code to read:
Sub EasySplit()
Dim text As String
Dim a As Integer
Dim name As Variant
text = ActiveCell.Value
name = Split(text, "-", 2)
For a = 0 To 1
ActiveCell.Offset(0, 3 + a).Value = Trim(name(a))
Next a
End Sub
Not quite the colkumn1,column4 output that I want (it outputs to column3,column4), but it will work for my purpose.
Now I need to incorporate a loop so that the code runs on each successive cell in the column (downwards, step 1) skipping all bolded cells, until it hits an empty cell.
Modified answer to modified request.
This will start on row 1 and continue until a blank cell is found in column A. If you would like to start on a different row, perhaps row 2 if you have headers, change the
i = 1
line to
i = 2
I added a check on the upper bound of our variant before doing the output writes, in case the macro is run again on already formatted cells. (Does nothing instead of erroring out)
Sub EasySplit()
Dim initialText As String
Dim i As Double
Dim name As Variant
i = 1
Do While Trim(Cells(i, 1)) <> ""
If Not Cells(i, 1).Font.Bold Then
initialText = Cells(i, 1).text
name = Split(initialText, "-", 2)
If Not UBound(name) < 1 Then
Cells(i, 1) = Trim(name(0))
Cells(i, 4) = Trim(name(1))
End If
End If
i = i + 1
Loop
End Sub
just add a variable to keep track of the active row and then use that in place of the constant 1.
e.g.
Dim iRow as Integer = ActiveCell.Row
For a = 0 To 1
Cells(iRow , a + 3).Value = Trim(name(a))
Next a
Alternate method utilizing TextToColumns. This code also avoids using a loop, making it more efficient and much faster. Comments have been added to assist with understanding the code.
EDIT: I have expanded the code to make it more versatile by using a temp worksheet. You can then output the two columns to wherever you'd like. As stated in your original question, the output is now to columns 1 and 4.
Sub tgr()
Const DataCol As String = "A" 'Change to the correct column letter
Const HeaderRow As Long = 1 'Change to be the correct header row
Dim rngOriginal As Range 'Use this variable to capture your original data
'Capture the original data, starting in Data column and the header row + 1
Set rngOriginal = Range(DataCol & HeaderRow + 1, Cells(Rows.Count, DataCol).End(xlUp))
If rngOriginal.Row < HeaderRow + 1 Then Exit Sub 'No data
'We will be using a temp worksheet, and to avoid a prompt when we delete the temp worksheet we turn off alerts
'We also turn off screenupdating to prevent "screen flickering"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Move the original data to a temp worksheet to perform the split
'To avoid having leading/trailing spaces, replace all instances of " - " with simply "-"
'Lastly, move the split data to desired locations and remove the temp worksheet
With Sheets.Add.Range("A1").Resize(rngOriginal.Rows.Count)
.Value = rngOriginal.Value
.Replace " - ", "-"
.TextToColumns .Cells, xlDelimited, Other:=True, OtherChar:="-"
rngOriginal.Value = .Value
rngOriginal.Offset(, 3).Value = .Offset(, 1).Value
.Worksheet.Delete
End With
'Now that all operations have completed, turn alerts and screenupdating back on
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
You can do this in a single shot without looping using the VBA equivalent of entering this formula, then taking values only
as a formula
=IF(NOT(ISERROR(FIND("-",A1))),RIGHT(A1,LEN(A1)-FIND("-",A1)-1 ),A1)
code
Sub Quicker()
Dim rng1 As Range
Set rng1 = Range([a1], Cells(Rows.Count, "A").End(xlUp))
With rng1.Offset(0, 3)
.FormulaR1C1 = "=IF(NOT(ISERROR(FIND(""-"",RC[-3]))),RIGHT(RC[-3],LEN(RC[-3])-FIND(""-"",RC[-3])-1 ),RC[-3])"
.Value = .Value
End With
End Sub
I have written an Excel VBA to copy data from selected cells from one workbook sheet to another. Here it is working fine upto certain cells, after pasting some values, after sometime VBA is pasting empty values. I mean eventhough the source cell is not empty, it is pasting empty values. I have put breakpoint and saw, but the value was there. Please help me to solve this issue.
The code is as follows.
Set objClickScriptWB = objExcelWB.Workbooks.Open(SourceWBPath)
For intSheet = 9 To 12 'objClickScriptWB.Worksheets.Count
If InStr(1, objClickScriptWB.Worksheets(intSheet).Name, "SC", vbTextCompare) > 0 Then
blnScriptSheet = 1
objClickScriptWB.Worksheets(intSheet).Activate
For r = 24 To objClickScriptWB.Worksheets(intSheet).UsedRange.Rows.Count
If Trim(LCase(objClickScriptWB.Worksheets(intSheet).Cells(r, 6).Value)) <> Trim(LCase("Transaction")) And Trim(LCase(objClickScriptWB.Worksheets(intSheet).Cells(r, 6).Value)) <> Empty And objClickScriptWB.Worksheets(intSheet).Cells(r, 6).MergeArea.Cells.Count = 1 Then
objClickScriptWB.Worksheets(intSheet).Cells(r, 6).Select
If blnCompSht = 0 Then
Set objComparisonSheet = ThisWorkbook.Worksheets.Add
objComparisonSheet.Name = "Comparison"
objComparisonSheet.Activate
objComparisonSheet.Cells(2, 2).Value = "Clickscript Transaction names"
i = 3
objExcelWB.Selection.Copy
objComparisonSheet.Activate
objComparisonSheet.Cells(i, 2).Select
'Sheet3.Range("B2").Select
'objComparisonSheet.Range("B" & i).PasteSpecial Paste:=xlPasteValues
objComparisonSheet.Paste
'Sheet2.Range("G2").Cells
i = i + 1
blnCompSht = 1
'Application.Wait (Now + TimeValue("00:00:01"))
ElseIf blnCompSht = 1 Then
ThisWorkbook.Worksheets("Comparison").Activate
Dim LastRow As Integer
For intRow = 2 To ThisWorkbook.Worksheets("Comparison").Rows.Count
If ThisWorkbook.Worksheets("Comparison").Cells(intRow, 2).Value = Empty Then
i = intRow
Exit For
End If
Next
objExcelWB.Selection.Copy
ThisWorkbook.Worksheets("Comparison").Cells(i, 2).Select
'ThisWorkbook.Worksheets("Comparison").Range("B" & intRow).PasteSpecial Paste:=xlPasteValues
ThisWorkbook.Worksheets("Comparison").Paste
i = i + 1
'Application.Wait (Now + TimeValue("00:00:01"))
End If
'End If
'Next
'Call CompareTxnNames(objClickScriptWB.Worksheets(intSheet).Name)
End If
'Next
Next
End If
Next
End Sub
Please help me
Thanks
You could also directly apply the value of one cell to the other cell with a code like this:
CellTarget.Value2 = CellSource.Value2
Or in your case:
objComparisonSheet.Cells(i, 2).Value2 = objClickScriptWB.Worksheets(intSheet).Cells(r, 6).Value2
Side note:
Get into the habit of using Value2 for that is the true value of the cell compared to Value which is the value with formatting applied to it. The latter is slower and in case of date values can give wrong days and months when you arent using the US dateformat in your excel.