I'm trying to compare 2 (B and C) columns and write in column D match or no match at a push of a button in Excel but I'm new to VBA.
Here is some of my noobie tries. I know it's not dynamic but I'm stuck and I can't figure this out. So bear with me. Any help is much appreciated
Private Sub CommandButton1_Click()
Dim bothcolumns As Range, i As Integer
Set bothcolumns = [B2:B3000, C2:C3000]
With bothcolumns
For i = 1 To .Rows.Count
If Not StrComp(.Cells(i, 1), .Cells(i, 2), vbBinaryCompare) = 0 Then
With Value
For i = 1 To .Rows.Count
Range(.Cells(i, 5)).Value = "NoMatch"
Range(.Cells(i, 1), .Cells(i, 2)).Interior.ColorIndex = 3
Range("E1:E300").Value = "NoMatch"
ElseIf Not StrComp(.Cells(i, 1), .Cells(i, 2), vbBinaryCompare) = 1 Then
Range("E1:E300").Value = "Match"
End If
Next i
End With
End Sub
I don't know why is you error, but you have two loop for, and just one Next i. In addition your two loops have the same indent variable i.
This will iterate over all the used rows in the worksheet, and then compare the cells value of the columns 'B' and 'C'.
Try this code:
Private Sub CommandButton1_Click()
Dim rowsMax As Long
Dim i As Long
'This gets the total of used rows in the Worksheet
rowsMax = ThisWorkbook.ActiveSheet.UsedRange.Rows.Count
For i = 2 To rowsMax
If ThisWorkbook.ActiveSheet.Cells(i, 2).Value = ThisWorkbook.ActiveSheet.Cells(i, 3).Value Then
ThisWorkbook.ActiveSheet.Cells(i, 4).Value = "Match"
Else
ThisWorkbook.ActiveSheet.Cells(i, 4).Value = "No Match"
End If
Next
End Sub
Some Tips:
i and Value are not declared. From my experience i should declare As Long and Value should declare As Worskheet
With Value and the second For i = 1 To .Rows.Count do not close with Next i and End with respectively.
For i is better to use As Long to avoid errors when you deal with large data size.
You use .Cells BUT you dont use . before the Range so the range you what does not included in the upper With.
bothcolumns is declare As Range, BUT you use []which is wrong. Also you set the range BUT you miss the Sheet name (e.g. Set bothcolumns = ThisWorkbook.Worksheets("Sheet1").Range(...). In my opinion the best set is Set bothcolumns = ThisWorkbook.Worksheets("Sheet1").Range("B2:C3000")
Related
I am looking to search the text in first column for specific words and when they're found copy and paste the adjacent column to somewhere else.
I've got this code which works fine if the text is exactly those words but if anything else is there it fails (i.e super consolidator).
I'm still very new to VBA and have just adapted some other code to get to this point. I figure the find function would be a good way to go about it but I can't wrap my head around how to avoid the infinite loops. Any help here would be appreciated
Sub Test()
Dim lr As Long
Dim r As Long
' Find last row in column A with data
lr = Cells(Rows.Count, "A").End(xlUp).Row
' Loop through all rows in column A
For r = 1 To lr
' Check value on entry
If (Cells(r, "A") = "Super") Or (Cells(r, "A") = "Pension") Or (Cells(r, "A") = "SMSF") Then
' Copy column B and paste in C where found
Cells(r, "B").Select
Selection.Copy
ActiveCell.Offset(0, 1).PasteSpecial
End If
Next r
End Sub
What you're looking for is called Wildcard string comparision. And you can use VBA's Like operator to achieve your output
If (Cells(r, "A") Like "Super*") Or (Cells(r, "A") Like "Pension*") Or (Cells(r, "A") Like "SMSF*") Then
Here the * in Super* means that the text should start with "Super" and it can have anything after that.
If you'd like to search if the cell contains "Super" anywhere, you can use *Super* - * at both ends of Super
To have a more robust code I moved the "signal" words you are checking for into an array at the beginning of the sub.
Same with the column indexes of the column you want to copy and the target index.
By that it is much easier to make adjustments if the requirements change, e.g. look for a forth word etc.
Furthermore you should avoid implicit referencing cells. That's why I added the ws-variable - you have to adjust your sheet name.
Plus I added a generic function isInArray that takes the cell-value plus the array with the lookup values and returns true or false. Here the like-operator is implemented.
You don't need to select-copy/paste the values - you can simply write them to the target cell: .Cells(r, targetColumnIndex).value = .Cells(r, sourceColumnIndex).value.
But be aware: if you have a lot of data it would make more sense to load everything into an array and work on that ... but that's the next lesson to learn ;-)
Option Explicit
Public Sub copyValues()
Dim arrLookupValues(2) As Variant
arrLookupValues(0) = "Super"
arrLookupValues(1) = "Pension"
arrLookupValues(2) = "SMSF"
Const sourceColumnIndex As Long = 2 'take value from column B
Const targetColumnIndex As Long = 3 'write value to colum C
application.screenupdating = false
Dim lr As Long
Dim r As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'adjust this to your needs
With ws
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
For r = 1 To lr
' Check value on entry
If isInArray(.Cells(r, 1).value, arrLookupValues) Then
' write value of column B (2) to C (3)
.Cells(r, targetColumnIndex).value = .Cells(r, sourceColumnIndex).value
End If
Next r
End With
application.screenupdating = true
End Sub
Private Function isInArray(value As Variant, arrLookFor As Variant) As Boolean
Dim i As Long
For i = LBound(arrLookFor) To UBound(arrLookFor)
If value like arrLookFor(i) & "*" Then
isInArray = True
Exit For
End If
Next
End Function
Would like to ask if it is possible to create a condition in excel vba for inserting rows of matched values in output file
for example:
This is an example list of my student:
This one is for the checklist of their exams / questionnaires:
This would be the final output:
Is it possible for VBA to look like in the results file? I only figured out how to put the number series per TestLEVEL value. But still thinking how to insert the Questionnaire and Value columns exactly the way I want.
THANKS! hope it is possible
Upon further reflection, and assuming I have understood your requirements correctly, I think the easiest way to do this is by using the FILTER-function. Note that this function is only available in Office 365, and that your argument separator might be a different one than mine.
It is also not ideal for automating the task since I assume the number of Questionnaire / Value pairs will be different from time to time. It is fairly simple to use though, so I guess it won't be a lot of work to create the formulas.
The way I did it was creating a duplicate of the second sheet you have a picture of into my workbook, and then create a sheet similar to the third one you have a picture of. In this sheet I put the formula
=FILTER(Sheet1!$C$2:$C$19;Sheet1!$A$2:$A$19=D2;NA())
into cell F2 and
=FILTER(Sheet1!$D$2:$D$19;Sheet1!$A$2:$A$19=D2;NA())
into G2.
The formula then fills the filtered range into the column as shown below:
To get the Questionnaire values of the student with student no. 4321 into range F8:F13, use the formula
=FILTER(Sheet1!$C$2:$C$19;Sheet1!$A$2:$A$19=D8;NA())
and so on.
I think this should solve your problem as presented in the question, at least, though your sheet will probably need a bit of editing if you have different input data.
As a further tip, I would recommend changing your data to tables when that is what they basically are anyway, it makes referencing them a bit simpler.
I hope this was of some help to you, don't hesitate to ask if something seems unclear.
Use Find and FindNext to match the Student No and Test Levels on the 2 sheets.
Option Explicit
Sub MyMacro()
Dim wb As Workbook
Dim wsName As Worksheet, wsExam As Worksheet, wsOut As Worksheet
Dim rng As Range, rngNo As Range
Dim iLastRow As Long, r As Long, rOut As Long
Dim n As Integer, m As Integer, i As Long
Dim sNo As String, sTest As String, sFirstFind As String
Set wb = ThisWorkbook
Set wsName = wb.Sheets("Sheet1")
Set wsExam = wb.Sheets("Sheet2")
Set rngNo = wsExam.UsedRange.Columns("A:A") ' student no
Set wsOut = wb.Sheets("Sheet3")
wsOut.Cells.Clear
i = 1 ' col A no
n = 0 ' block row for Col B-F
m = 0 ' block row for Col G-H
rOut = 2
iLastRow = wsName.Cells(Rows.Count, "A").End(xlUp).Row
For r = 2 To iLastRow
sTest = wsName.Cells(r, "D")
sNo = wsName.Cells(r, "C")
' start new block if no or test different to previous row
If sNo <> wsName.Cells(r - 1, "C") _
Or sTest <> wsName.Cells(r - 1, "D") Then
' align columns
If m > n Then
rOut = rOut + m
Else
rOut = rOut + n
End If
n = 0
m = 0
' start new test
sTest = wsName.Cells(r, "D")
If sTest <> wsName.Cells(r - 1, "D") Then
wsOut.Cells(rOut, "A") = i
i = i + 1
End If
' search for matching Student No
Set rng = rngNo.Find(sNo, LookIn:=xlValues, lookat:=xlWhole)
If rng Is Nothing Then
Else
sFirstFind = rng.Address
Do
'is testlevel the same
If rng.Offset(0, 4) = sTest Then
' copy col C-D to G-H
rng.Offset(0, 2).Resize(1, 2).Copy wsOut.Cells(rOut + m, "G")
m = m + 1
End If
' find next
Set rng = rngNo.FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> sFirstFind
End If
End If
' copy col A-E to col B-F
wsName.Cells(r, "A").Resize(1, 5).Copy wsOut.Cells(rOut + n, "B")
n = n + 1
Next
MsgBox "Done", vbInformation
End Sub
I have problem on swapping Column A to Column B then Column B to Column A, both column has row count of 2563. Is there any vba code to solve this problem?
I'm Already trying this code:
Private Sub CommandButton1_Click()
Dim temp As Double
temp = Range("A1").Value
Range("A1").Value = Range("B1").Value
Range("B1").Value = temp
End Sub
But it can only swap row 1 of both columns...
You can swap them all by a loop. For your case, the loop should go for 2563 times.
Private Sub CommandButton1_Click()
For i = 1 To 2563
temp = Cells(i, 1).Value
Cells(i, 1).Value = Cells(i, 2).Value
Cells(i, 2).Value = temp
Next i
End Sub
Using an array would be much faster than looping. In this example column A is copied into an array Hold_RNG. Then Column B is copied to column A, and then the Array is copied into Column B.
Sub SwapCOlumns()
Dim hold_rng() As Variant
Dim rowsToinclude As Long, WS As Worksheet
Set WS = ActiveSheet '<--- make sure this is correct worksheet
rowsToinclude = 2563 '<----- might want to make more dynamic
With WS
hold_rng = .Range("A1:A" & rowsToinclude)
.Range("A1:A" & rowsToinclude).Value = .Range("B1:B" & rowsToinclude).Value
.Range("B1:B" & rowsToinclude).Value = hold_rng
End With
End Sub
Updated: I don't mean to pick on the competing answer as it's simple and effective, but our two answers offer a good illustration of why using Arrays to impact a spreadsheet all at once, is much more efficient than looping and editing. I built this code which will time the results of each approach (inserting in Column E) of a spreadsheet. Through one round of 2563 rows the score was 0 seconds to 4. The array continued to output in 0 seconds while the loop approach fell to 41 seconds when doing 9 trials.
Screen Shot Of Results.
Timing code can be found on my PasteBin page (I don't want this answer to look ridiculously long)
I prefer to use arrays because is much faster.
Option Explicit
Sub test()
Dim i As Long
Dim arrA As Variant, arrB As Variant
Dim ValueA As Double, ValueB As Double
'Cahng if needed
With ThisWorkbook.Worksheets("Sheet1")
arrA = .Range("A1:A2563")
arrB = .Range("B1:B2563")
For i = 1 To 2563
ValueA = arrA(i, 1)
ValueB = arrB(i, 1)
arrA(i, 1) = ValueB
arrB(i, 1) = ValueA
Next i
.Range("A1").Resize(UBound(arrA), 1) = arrA
.Range("B1").Resize(UBound(arrB), 1) = arrB
End With
End Sub
Just to add it into the mix, there is a third way.
Insert a column after B. Copy A to C. Delete A.
With ThisWorkbook.Worksheets(1)
.Columns(3).Insert
.Columns(1).Copy .Columns(3)
.Columns(1).Delete
End With
(It assumes you want to move the whole column, but you normally would.)
However, the speed at which this will run depends upon the size of the worksheet and how many formulae it has.
I am attempting to run a VBA macro that iterates down about 67,000 rows with 100 columns in each row. For each of the cells in these rows, the value is compared against a column with 87 entries in another sheet. There are no errors noted when the code is run but Excel crashes every time. The odd thing is that the code seems to work; I have it set to mark each row in which a match is found and it does so before crashing. I have attempted to run it many times and it has gotten through between 800 and 11,000 rows before crashing, depending on the attempt.
My first suspect was memory overflow due to the volume of calculations but my system shows CPU utilization at 100% and memory usage around 50% while running this code:
Sub Verify()
Dim codes As String
Dim field As Object
For i = 2 To Sheets("DSaudit").Rows.Count
For Each field In Sheets("Dsaudit").Range(Cells(i, 12), Cells(i, 111))
r = 1
While r <= 87
codes = ThisWorkbook.Sheets("287 Denominator CPT").Cells(r, 1).Value
If field = codes Then
Cells(i, 112).Value = "True"
r = 88
Else
r = r + 1
End If
Wend
Next field
i = i + 1
Next i
End Sub
It should also be noted that I am still very new to VBA so it's likely I've made some sort of egregious rookie mistake. Can I make some alterations to this code to avoid a crash or should I scrap it and take a more efficient approach?
When ever possible iterate variant arrays. This limits the number of times vba needs to access the worksheet.
Every time the veil between vba and Excel is pierced cost time. This only pierces that veil 3 times not 9,031,385,088
Sub Verify()
With Sheets("DSaudit")
'Get last row of Data
Dim lastrow As Long
lastrow = .Cells(.Rows.Count, 12).End(xlUp).Row 'if column 12 ends before the last row of data change to column that has them all.
'Load Array with input Values
Dim rng As Variant
rng = .Range(.Cells(2, 12), .Cells(lastrow, 111)).Value
'Create output array
Dim outpt As Variant
ReDim outpt(1 To UBound(rng, 1), 1 To 1)
'Create Match array
Dim mtch As Variant
mtch = Worksheets("287 Denominator CPT").Range("A1:A87").Value
'Loop through first dimension(Row)
Dim i As Long
For i = LBound(rng, 1) To UBound(rng, 1)
'Loop second dimension(Column)
Dim j As Long
For j = LBound(rng, 2) To UBound(rng, 2)
'Loop Match array
Dim k As Long
For k = LBound(mtch, 1) To UBound(mtch, 1)
'If eqaul set value in output and exit the inner loop
If mtch(k, 1) = rng(i, j) Then
outpt(i, 1) = "True"
Exit For
End If
Next k
'If filled true then exit this for
If outpt(i, 1) = "True" Then Exit For
Next j
Next i
'Assign the values to the cells.
.Cells(2, 112).Resize(UBound(outpt, 1), 1).Value = outpt
End With
End Sub
I'm currently looking for a code to improve my Dashboard. Actually, I need to know how to use a loop in a column X who will affect a column Y (cell on the same line).
To give you an example:
Column A: I have all Production Order (no empty cell)
Column B: Cost of goods Sold (Sometimes blank but doesn't matter)
I actually pull information from SAP so my Column B is not in "Currency".
The action should be:
If A+i is not empty, then value of B+i becomes "Currency".
It's also for me to get a "generic" code that I could use with other things.
This is my current code...
Sub LoopTest()
' Select cell A2, *first line of data*.
Range("A2").Select
' Set Do loop to stop when an empty cell is reached.
Do Until IsEmpty(ActiveCell)
ActiveCell.Offset(0, 1).Style = "Currency"
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Another example, getting Last Row, in case your data contains any blank rows.
Sub UpdateColumns()
Dim wks As Worksheet
Dim lastRow As Long
Dim r As Long
Set wks = ActiveSheet
lastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
For r = 2 To lastRow
If wks.Cells(r, 1) <> "" Then
wks.Cells(r, 2).NumberFormat = "$#,##0.00"
End If
Next r
End Sub
I can see I was a little slower than the others, but if you want some more inspiration, heer is a super simple solution (as in easy to understand as well)
Sub FormatAsCurrency()
'Dim and set row counter
Dim r As Long
r = 1
'Loop all rows, until "A" is blank
Do While (Cells(r, "A").Value <> "")
'Format as currency, if not blank'
If (Cells(r, "B").Value <> "") Then
Cells(r, "B").Style = "Currency"
End If
'Increment row
r = r + 1
Loop
End Sub
Try the following:
Sub calcColumnB()
Dim strLength As Integer
Dim i As Long
For i = 1 To Rows.Count
columnAContents = Cells(i, 1).Value
strLength = Len(columnAContents)
If strLength > 0 Then
Cells(i, 2).NumberFormat = "$#,##0.00"
End If
Next i
End Sub
Explanation--
What the above code does is for each cell in Column B, so long as content in column A is not empty, it sets the format to a currency with 2 decimal places
EDIT:
Did not need to loop
Here's a really simply one, that I tried to comment - but the formatting got messed up. It simply reads column 1 (A) for content. If column 1 (A) is not empty it updates column 2 (B) as a currency. Changing active cells makes VBA more complicated than it needs to be (in my opinion)
Sub LoopTest()
Dim row As Integer
row = 1
While Not IsEmpty(Cells(row, 1))
Cells(row, 2).Style = "Currency"
row = row + 1
Wend
End Sub