For each cell in column range table - excel

I need help fixing my code and adding in the cell ranges.
I am trying to change the values in the cells to being the correct values if they are spelt incorrectly. But the table will be added to so I need to make it a flexible code. The code currently stops at the beginning sub with error code 424. I am fairly new to VBA and am stuck.
Sub Consolidates()
Dim datasheet As Worksheet
Set datasheet = ThisWorkbook.Sheets("sheet1")
lr = datasheet.Cells(Rows.Count, 9).End(xlUp).Row
For x = 2 To lr
If cell.Value = "B" Or "BR" Or " Then
cell.Value = "BR"
ElseIf cell.Value = "CL" Or "CR" _
Then cell.Value = "CR"
ElseIf cell.Value = "" Then
End If
Next x
End Sub

you could use something like follows
Option Explicit
Sub Consolidates()
Dim stringsToSearch As String, stringToSubstitute As String
Dim stringsToSearchArr As Variant, stringToSubstituteArr As Variant
' here define the "table"
stringsToSearch = "B,CL" '<--| type here the strings to be searched for
stringToSubstitute = "BR,CR" '<--| type here the corresponding strings to change searched ones into
stringsToSearchArr = Split(stringsToSearch, ",") '<--| turn "stringsToSearch" into an array
stringToSubstituteArr = Split(stringToSubstitute, ",") '<--| turn "stringToSubstitute" into an array
With ThisWorkbook.Sheets("sheetTest") '<--| change "sheetTest" with your actual sheet name
With .Range("I2:I" & .Cells(.Rows.Count, 9).End(xlUp).Row) '<--| consider all cells in column "I" from row 2 to last non empty one
For i = LBound(stringsToSearchArr) To UBound(stringsToSearchArr) '<--| loop through the "table"
.Replace What:=stringsToSearchArr(i), Replacement:=stringToSubstituteArr(i), LookAt:=xlWhole, MatchCase:=True '<--| find current string and replace it with its corresponding replacement
Next i
End With
End With
End Sub

Cell needs a reference to which cell. Also you can't use the or statement like that. Below a simple way to get it done.
For x = 1 To lr
If Cells(x, 9).Value = "B" Or Cells(x, 9).Value = "BR" Then
Cells(x, 9).Value = "BR"
ElseIf Cells(x, 9).Value = "CL" Or Cells(x, 9).Value = "CR" Then
Cells(x, 9).Value = "CR"
End If
Next x
You should consider a select statement
For x = 1 To lr
Select Case Cells(x, 9).Value
Case "B", "BR"
Cells(x, 9).Value = "BR"
Case "CL", "CR"
Cells(x, 9).Value = "CR"
End Select
Next x
Since it is case sensitive you could add an Lcase which could save you some time
For x = 1 To lr
Select Case LCase(Cells(x, 9).Value)
Case "b", "br"
Cells(x, 9).Value = "BR"
Case "cl", "cr"
Cells(x, 9).Value = "CR"
End Select
Next x

Related

Why does this vba sentence go wrong? If Cells(i, 1).Value = "M" Then

Sub a()
Dim i As Integer
For i = 1 To 8
If Cells(i, 1).Value = "M" Then
Cells(i, 2).Value = ""
End If
Next i
End Sub
You need to include the sheet information along with the cells.
Example: Sheet1.Cells(i,1).Value or Worksheets("Sheet name").Cells(i,1).Value

Copy rows with specific columns based on entered date to other sheet

I have an existing VBA code that copies rows if an identifier column is marked with 'X'. Now I want it to be based off a date range entered by the user. Can somebody please help me convert the existing code to my required one? Thanks!
Sub CopyRow()
Application.ScreenUpdating = False
Dim x As Long, MaxRowList As Long, MaxRowList2 As Long, S As String, wsSource As Worksheet, wsTarget As Worksheet, S2 As Long
Set wsSource = ThisWorkbook.Worksheets("Sheet 1 - RAW")
Set wsTarget = ThisWorkbook.Worksheets("Staging")
iCol = 1
MaxRowList = wsSource.Cells(Rows.Count, iCol).End(xlUp).Row
MaxRowList2 = wsTarget.Cells(Rows.Count, iCol).End(xlUp).Row
S2 = 8
wsTarget.Range("A8:H22").ClearContents
For x = 4 To MaxRowList
If InStr(1, wsSource.Cells(x, 19), "X") Then
wsTarget.Cells(S2, 1).Value = wsSource.Cells(x, 1).Value
wsTarget.Cells(S2, 4).Value = wsSource.Cells(x, 2).Value
wsTarget.Cells(S2, 5).Value = wsSource.Cells(x, 10).Value
wsTarget.Cells(S2, 6).Value = wsSource.Cells(x, 16).Value
wsTarget.Cells(S2, 7).Value = wsSource.Cells(x, 18).Value
wsTarget.Cells(S2, 8).Value = wsSource.Cells(x, 17).Value
S2 = S2 + 1
End If
Next
Application.ScreenUpdating = True
End Sub
You need to modify your if Statement.
If InStr(1, wsSource.Cells(x, 19), "X") Then
Will become
If wsSource.Cells(x, ColumnThatContainsTheDate).value > OlderDate and wsSource.Cells(x, 19).value < NewerDate Then
Now, your problem will become how do you want the user to select the dates? A form that he could dynamically select (using a calendar), just a plain input box or based on a value of a cell? Do you want everything that is older or newer to this date or do you want between two dates? Just adjust the statement to whatever suits your needs.

read Cellvalue through a range, and write to a different range

I am trying to make a VBA scrip that check all cells between B2 and B60 for the text "Ja" that's yes in Norwegian.
How can I make this a little bit simpler that making a "if" command for each cell?
I want it to, if the cell contains "ja"(yes) then write to colum D and the same number.
ie. B1,2,3,4,5 cotains "ja", I need it to take the previous cell value in D1.2,3,4,5 and add another digit to it +1.
If nothing is found in B(ie.false) it needs to write "NEI" in the current cell, and if "NEI" (no) is found in that cell it adds +1 to colum E
Sub Macro2()
Dim celltxt As String
Dim a As Variant
If IsEmpty(Range("B2").Value) = True Then
Cells(2, 2).Value = "NEI"
End If
celltxt = ActiveSheet.Range("B2").Text
If InStr(1, celltxt, "ja") Then
a = Cells(2, 1).Value
'write to cell
Cells(2, 4).Value = Cells(2, 4) + 1
Else
'antall Cw'er vedkommende IKKE har deltatt på
Cells(2, 5).Value = Cells(2, 5) + 1
End If
If IsEmpty(Range("B3").Value) = True Then
Cells(3, 2).Value = "NEI"
End If
celltxt = ActiveSheet.Range("B3").Text
If InStr(1, celltxt, "ja") Then
a = Cells(3, 1).Value
'write to cell
Cells(3, 4).Value = Cells(3, 4) + 1
Else
'antall Cw'er vedkommende IKKE har deltatt på
Cells(3, 5).Value = Cells(3, 5) + 1
End If
End Sub
Sub slettingALL()
Range("D2:E55").Select
Selection.ClearContents
End Sub
Sub slettingdeltakelse()
Range("B2:B60").Select
Selection.ClearContents
End Sub
The following code uses a For Each loop and an IF THEN ELSE statement to check for the value "JA" in the range B2:B60.
If it finds "JA", it looks two columns to the right from the current i location, and adds "+1" to the value above it. If it finds nothing, it writes "NEI" to the current i location, and then moves three columns to the right and adds +1 to the value above it.
Sub Macro2()
For Each i In Range(Cells(2, 2), Cells(60, 2))
If i.Value = "JA" Then
i.Offset(0, 2).Value = i.Offset(-1, 2).Value + 1
Else
i.Value = "NEI"
i.Offset(0, 3).Value = i.Offset(-1, 3).Value + 1
End If
Next i
End Sub
Please let me know if this code does not work for your purpose.

Delete row based on one letter

Need help with my code.
In (Column C) I have values MG01, MG02a, MG02b, MG02c. And in (Column A) different values. Code needs to delete row if value in column A is "1" and
in Column C if it finds letters at the end of text such as b, c, d, e, ....
And with "c" code do not recognized MG02c help please.
Sub xDeleteRowz()
Last = Cells(Rows.Count, "A").End(xlUp).Row
For i = Last To 1 Step -1
If (Cells(i, "A").Value) = "1" And (Cells(i, "C").Value) = "*c*" Then
Cells(i, "A").EntireRow.Delete
End If
Next i
End Sub
This sounds like something more suited for a regular expression:
Sub xDeleteRowz()
Last = Cells(Rows.Count, "A").End(xlUp).Row
With CreateObject("VBScript.RegExp")
.Pattern = "MG\d{2}[a-z]"
.IgnoreCase = False
For i = Last To 1 Step -1
If (Cells(i, "A").Value) = "1" And .Test(Cells(i, "C").Value) Then
Cells(i, "A").EntireRow.Delete
End If
Next i
End With
End Sub
Note that the expression requires the value to begin with MG##. If the start of the value can be different, replace this line...
.Pattern = "MG\d{2}[a-z]"
...with...
.Pattern = ".+[a-z]"
... and it will match anything with a lowercase letter at the end. You can also limit to specific letters by changing the range inside the brackets. I.e., if it's only 'a' through 'g', it would be:
.Pattern = ".+[a-g]"
Change
If (Cells(i, "A").Value) = "1" And (Cells(i, "C").Value) = "*c*" Then
to
If (Cells(i, "A").Value) = "1" And (Cells(i, "C").Value) like "*c*" Then
or
If (Cells(i, "A").Value) = "1" And InStr(1, Cells(i, "C").Value, "c", vbTextCompare) Then
May I also suggest that you make some more changes to your code and start coding explicitly like so:
Option Explicit
Sub xDeleteRowz()
Dim i As Long, Last As Long
Last = Cells(Rows.Count, "A").End(xlUp).Row
With ThisWorkbook.Worksheets(1)
For i = Last To 1 Step -1
If .Cells(i, "A").Value = "1" And InStr(1, .Cells(i, "C").Value, "c", vbTextCompare) Then
.Rows(i).EntireRow.Delete
End If
Next i
End With
End Sub
Update:
Based on the latest comment a more suitable approach might be the following:
Option Explicit
Sub xDeleteRowz()
Dim i As Long, Last As Long
Last = Cells(Rows.Count, "A").End(xlUp).Row
With ThisWorkbook.Worksheets(1)
For i = Last To 1 Step -1
If .Cells(i, "A").Value = "1" Then
Select Case LCase(Right(.Cells(i, "C").Value, 1))
Case "b", "c", "d", "e", "f", "g"
.Rows(i).EntireRow.Delete
End Select
End If
Next i
End With
End Sub

Matching pairs of cells while iterating through columns to then return a new pair of cells

I am trying to write a code that will take one cell and then iterate through another column to find a match, once it has found a match it will then match two other cells in that same row and return the value of a 5th and 6th cell. However, it is not working! any suggestions??
Sub rates()
Dim i As Integer
For i = 2 To 2187
If Cells(i, 1).Value = Cells(i, 11).Value Then
If Cells(i, 2).Value = Cells(i, 12).Value Then
Cells(i, 20) = Cells(i, 1).Value
Cells(i, 21) = Cells(i, 11).Value
Cells(i, 22) = Cells(i, 4).Value
Cells(i, 23) = Cells(i, 16).Value
Else
Cells(i, 24) = "No match"
End If
End If
Next i
End Sub
Try fully qualifying your cell objects i.e. sheet1.cells(i,1).value etc or encase within a with statement i.e.
with sheet1
if .cells(i,X) = .cells(i,Y) then
'...etc
end with
I think the default property for a range is "Value" but try putting .Value on to the end of all those Cell lines too... like you have for half of them :)
[EDIT/Addition:]
... failing that, you're not actually searching a whole column at any point: try something like:
Sub rates()
Dim i As Integer
Dim rgSearch As Range
Dim rgMatch As Range
Dim stAddress As String
Dim blMatch As Boolean
With wsSheet
Set rgSearch = .Range(.Cells(x1, y1), .Cells(x2, y2)) ' Replace where appropriate (y = 1 or 11 i guess, x = start and end row)
End With
For i = 2 To 2187
Set rgMatch = rgSearch.Find(wsSheet.Cells(i, y)) ' y = 1 or 11 (opposite of above!)
blMatch = False
If Not rgMatch Is Nothing Then
stAddress = rgMatch.Address
Do Until rgMatch Is Nothing Or rgMatch.Address = stAddress
If rgMatch.Offset(0, y).Value = Cells(i, 12).Value Then
Cells(i, 20) = Cells(i, 1).Value
Cells(i, 21) = Cells(i, 11).Value
Cells(i, 22) = Cells(i, 4).Value
Cells(i, 23) = Cells(i, 16).Value
blMatch = True
Else
End If
Set rgMatch = rgSearch.FindNext(rgMatch)
Loop
End If
If Not blMatch Then
Cells(i, 24) = "No match"
End If
Next i
End Sub
I've made a lot of assumptions in there and there's a few variables you'll have to replace. You could also probably use application.worksheetfunction.match but .find is quicker and more awesome

Resources