I was trying to create a script in vba which checks the cell "A1" and replaces the first 2 characters of the string with an integer. Should look something like this:
If (Left(A1, 2) = "NI") Then
newtext = Replace("originaltext", "NI", "801")
ElseIf (Left(A1, 2) = "RE") Then
newtext = Replace("originaltext", "RE", "821")
ElseIf (Left(A1, 2) = "NV") Then
newtext = Replace("originaltext", "NV", "571")
ElseIf (Left(A1, 2) = "NF") Then
newtext = Replace("originaltext", "NF", "831")
end if
n=n+1
Loop
I want it to go through every cell and do that action starting from a1 lets say all the way down to a2 and a3 and so on.
How do I create the right loop for that?
Consider:
Sub flay()
Dim i As Long, N As Long, v As Variant, frst As String
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
v = Cells(i, "A").Value
If Len(v) >= 2 Then
frst = Left(v, 2)
If frst = "RE" Then
Cells(i, "A").Value = Replace(v, "RE", "821")
ElseIf frst = "NI" Then
Cells(i, "A").Value = Replace(v, "NI", "801")
ElseIf frst = "NF" Then
Cells(i, "A").Value = Replace(v, "NF", "831")
ElseIf frst = "NV" Then
Cells(i, "A").Value = Replace(v, "NV", "571")
End If
End If
Next i
End Sub
Try the next code, please:
Sub testReplaceWithNumber()
Dim sh As Worksheet, lastR As Long, i As Long
Set sh = ActiveSheet 'use here the necessary sheet
lastR = sh.Range("A" & sh.Rows.count).End(xlUp).row
For i = 1 To lastR
Select Case left(sh.Range("A" & i).Value, 2)
Case "NI":
sh.Range("A" & i).Value = "801" & Mid(sh.Range("A" & i).Value, 3)
Case "RE":
sh.Range("A" & i).Value = "821" & Mid(sh.Range("A" & i).Value, 3)
Case "NV":
sh.Range("A" & i).Value = "571" & Mid(sh.Range("A" & i).Value, 3)
Case "NF":
sh.Range("A" & i).Value = "831" & Mid(sh.Range("A" & i).Value, 3)
End Select
Next i
End Sub
For each cl in
application.intersect(columns(1),activesheet.usedrange)
Select case left(cl,2)
Case "RE"
Mid(cl,1,2) ="821"
Case "NI"
Mid(cl,1,2) ="801"
' And so on
End select
Next
Related
I am working on a project to scans a list of dates in one column and values in another, and then appends a value to a string in a third column. What I am having trouble with is appending that same value to every cell above the specified date. The data looks like this:
What I need to have happen is for the values of T1, T2 etc. to be appended to the code for every cell above the last_month_row which does not already have a value appended. It should look like this:
My code thus far is this:
Sub Test_Logic()
Dim lastrow As Long, lastcolumn As Long, lastrow_reps As Long
Dim tmp As String, arr() As String, msg As String
Dim cell As Range
Dim i As Integer, j As Integer
Dim last_month As Long
Dim last_month_row As String, first_month_row As String
Dim ws As Worksheet, ws2 As Worksheet
Dim wb As Workbook
Dim reps As Variant, quota As Variant, repslist As Variant, ACV As Variant
Set wb = ActiveWorkbook
Set ws2 = wb.Sheets("Rep_Commission")
lastrow_reps = ws2.Cells(Rows.Count, 1).End(xlUp).Row
Set repslist = ws2.Range("A3:A" & (lastrow_reps))
Set ACV = ws2.Range("B3:B" & (lastrow_reps))
With wb
For Each reps In repslist
Set ws = Worksheets(reps.Text)
Set ACV = ws2.Range("A1:A99").Find(reps, LookIn:=xlValues).Offset(, 1)
lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
For Each cell In ws.Range("I2:I" & lastrow)
If (cell <> "") And (InStr(tmp, cell) = 0) Then
tmp = tmp & cell & "|"
End If
Next cell
If Len(tmp) > 0 Then tmp = Left(tmp, Len(tmp) - 1)
arr = Split(tmp, "|")
For i = LBound(arr) To UBound(arr)
msg = msg & arr(i) & vbNewLine
Next i
For i = LBound(arr) To UBound(arr)
'the error occurs here
last_month = ws.Range("I2:I" & lastrow).Find(What:=arr(i), searchdirection:=xlPrevious).Offset(, 6).Value
last_month_row = ws.Range("I2:I" & lastrow).Find(What:=arr(i), searchdirection:=xlPrevious).Offset(, 7).Row
first_month_row = ws.Range("I2:I" & lastrow).Find(What:=arr(i), searchdirection:=xlNext).Offset(, 7).Address
If last_month < (ACV / 2) Then
ws.Range("I2:I" & lastrow).Find(What:=arr(i), searchdirection:=xlPrevious).Offset(, 7).Value = ws.Range("I2:I" & lastrow).Find(What:=arr(i), searchdirection:=xlPrevious).Offset(, 5).Value & "T1"
For j = 2 To last_month_row - 1
If ws.Range("I" & j).Value = arr(i) Then
ws.Range("P" & j).Value = ws.Range("P" & j).Value & "T1"
End If
Next j
ElseIf last_month > (ACV / 2) And last_month < ACV Then
ws.Range("I2:I" & lastrow).Find(What:=arr(i), searchdirection:=xlPrevious).Offset(, 7).Value = ws.Range("I2:I" & lastrow).Find(What:=arr(i), searchdirection:=xlPrevious).Offset(, 5).Value & "T2"
For j = 2 To last_month_row - 1
If ws.Range("I" & j).Value = arr(i) Then
ws.Range("P" & j).Value = ws.Range("P" & j).Value & "T2"
End If
Next j
ElseIf last_month > ACV And last_month < (ACV * 1.5) Then
ws.Range("I2:I" & lastrow).Find(What:=arr(i), searchdirection:=xlPrevious).Offset(, 7).Value = ws.Range("I2:I" & lastrow).Find(What:=arr(i), searchdirection:=xlPrevious).Offset(, 5).Value & "T3"
For j = 2 To last_month_row - 1
If ws.Range("I" & j).Value = arr(i) Then
ws.Range("P" & j).Value = ws.Range("P" & j).Value & "T3"
End If
Next j
ElseIf last_month > (ACV * 1.5) Then
ws.Range("I2:I" & lastrow).Find(What:=arr(i), searchdirection:=xlPrevious).Offset(, 7).Value = ws.Range("I2:I" & lastrow).Find(What:=arr(i), searchdirection:=xlPrevious).Offset(, 5).Value & "T4"
For j = 2 To last_month_row - 1
If ws.Range("I" & j).Value = arr(i) Then
ws.Range("P" & j).Value = ws.Range("P" & j).Value & "T4"
End If
Next j
Else 'Do nothing yet, or maybe some error handling??
End If
Next i
Next reps
End With
End Sub
What I can't figure out is how to add the "T" values to the correct cells - I tried looping through a range created by first_month_row and last_month_row but ended up just appending multiples of the T values. Any advice would be appreciated.
EDIT: So I was successfully able to populate the cells, but when I try to loop through my worksheets I get an "Object Variable or With block Variable Not Set" Error. It occurs at this line:
last_month = ws.Range("I2:I" & lastrow).Find(What:=arr(i), searchdirection:=xlPrevious).Offset(, 6).Value
But last_month is a single value, not an object so I don't see why this is occurring.
Your sub does exactly what you have programmed. It finds the last occurence of arr(i) and sets the value in column P for the last row only. You'd rather loop this way to go through the ranges with the same date:
Dim last_month_row as long, first_month_row as long, k as long
For i = LBound(arr) To UBound(arr)
last_month_row = ws.Range("I2:I" & lastrow).Find(What:=arr(i), searchdirection:=xlPrevious).Offset(, 7).row
first_month_row = ws.Range("I2:I" & lastrow).Find(What:=arr(i), searchdirection:=xlNext).Offset(, 7).row
For k = first_month_row to last_month_row
If last_month < (ACV / 2) Then
ws.cells(k, "P").Value = ws.cells(k, "N").Value & "T1"
...
Additionally, I suggest using Long instead of Integer. VBA works with longs, you do not save anything with integers, but you risk an overflow going above 65K.
I think you need to add another Array/Collection that contains "ONLY" the "Unique" values for column "I", then use this Unique values to iterate/search inside your selection as the following pseudo code:
For Each Unq in UniqueDate
For i = LBound(arr) To UBound(arr)
// Here, use "Unq" instead of "arr(i)" to search/find your target value
next i
next Unq
For me, the easiest way to create a unique 'list' is by using "Collection" :
Dim UniqDate As New Collection
ws.Range("I2:I" & lastrow).Select
If Not Selection Is Nothing Then
For Each cell In Selection
UniqDate.Add cell, cell // Collection will ignore the value of "cell" if already exist (duplicated values filtering)
// the rest of your code is the same
If (cell <> "") And (InStr(tmp, cell) = 0) Then
tmp = tmp & cell & "|"
End If
Next cell
End If
I have a data like this :
A049
A050
A051
A053
A054
A055
A056
A062
A064
A065
A066
And I want the output like :
As you can see, I want the ranges which are in consecutive order
I am trying some thing like this:
Private Sub CommandButton1_Click()
Set wb = ThisWorkbook
lastRow = wb.Sheets("Sheet1").Range("A" & wb.Sheets("Sheet1").Rows.Count).End(xlUp).Row
For i = 2 To lastRow
r = wb.Sheets("Sheet1").Range("A" & i).Value
If wb.Sheets("Sheet1").Range("A" & i).Value = wb.Sheets("Sheet1").Range("A" & i+1).Value
Next i
End Sub
But not helping me
Am feeling charitable so have tried some code which should work. It assumes your starting values are in A1 down and puts results in C1 down.
Sub x()
Dim v1, v2(), i As Long, j As Long
v1 = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
ReDim v2(1 To UBound(v1, 1), 1 To 2)
For i = LBound(v1, 1) To UBound(v1, 1)
j = j + 1
v2(j, 1) = v1(i, 1)
If i <> UBound(v1, 1) Then
Do While Val(Right(v1(i + 1, 1), 3)) = Val(Right(v1(i, 1), 3)) + 1
i = i + 1
If i = UBound(v1, 1) Then
v2(j, 2) = v1(i, 1)
Exit Do
End If
Loop
End If
If v1(i, 1) <> v2(j, 1) Then v2(j, 2) = v1(i, 1)
Next i
Range("C1").Resize(j, 2) = v2
End Sub
Try the below code
Private Sub CommandButton1_Click()
Set wb = ThisWorkbook
lastRow = wb.Sheets("Sheet1").Range("A" & wb.Sheets("Sheet1").Rows.Count).End(xlUp).Row
Dim lastNum, Binsert As Integer
Dim firstCell, lastCell, currentCell As String
Binsert = 1
lastNum = getNum(wb.Sheets("Sheet1").Range("A1").Value)
firstCell = wb.Sheets("Sheet1").Range("A1").Value
For i = 2 To lastRow
activeNum = getNum(wb.Sheets("Sheet1").Range("A" & i).Value)
currentCell = wb.Sheets("Sheet1").Range("A" & i).Value
If (activeNum - lastNum) = 1 Then
'nothing
Else
lastCell = wb.Sheets("Sheet1").Range("A" & (i - 1)).Value
wb.Sheets("Sheet1").Range("B" & Binsert).FormulaR1C1() = firstCell
If (firstCell <> lastCell) Then
wb.Sheets("Sheet1").Range("C" & Binsert).FormulaR1C1() = lastCell
End If
Binsert = Binsert + 1
firstCell = wb.Sheets("Sheet1").Range("A" & i).Value
End If
lastNum = activeNum
Next i
'last entry
wb.Sheets("Sheet1").Range("B" & Binsert).FormulaR1C1() = firstCell
If (firstCell <> currentCell) Then
wb.Sheets("Sheet1").Range("C" & Binsert).FormulaR1C1() = currentCell
End If
End Sub
Public Function getNum(ByVal num As String) As Integer
getNum = Val(Mid(num, 2))
End Function
Another solution. It loops backwards from last row to first row.
Option Explicit
Public Sub FindConsecutiveValues()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim lRow As Long 'find last row
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Dim lVal As String 'remember last value (stop value)
lVal = ws.Range("A" & lRow).Value
Const fRow As Long = 2 'define first data row
Dim i As Long
For i = lRow To fRow Step -1 'loop from last row to first row backwards
Dim iVal As Long
iVal = Val(Right(ws.Range("A" & i).Value, Len(ws.Range("A" & i).Value) - 1)) 'get value of row i without A so we can calculate
Dim bVal As Long
bVal = 0 'reset value
If i <> fRow Then 'if we are on the first row there is no value before
bVal = Val(Right(ws.Range("A" & i - 1).Value, Len(ws.Range("A" & i - 1).Value) - 1)) 'get value of row i-1 without A
End If
If iVal - 1 = bVal Then
ws.Rows(i).Delete 'delete current row
Else
If lVal <> ws.Range("A" & i).Value Then 'if start and stop value are not the same …
ws.Range("B" & i).Value = lVal 'write stop value in column B
End If
lVal = ws.Range("A" & i - 1).Value 'remember now stop value
End If
Next i
End Sub
Image1
Hi, Referring to the image, I am trying to compare column G and Column K, if the value is the same then copy the value in column J to column F. However, my code doesn't copy the value from Column J to F.
Sub createarray1()
Dim i As Integer
Dim j As Integer
Dim masterarray As Range
Set masterarray = Range("D3:G12")
Dim sourcearray As Range
Set sourcearray = Range("H3:K26")
For i = 1 To 10
For j = 1 To 25
If masterarray(i, 4).Value = sourcearray(j, 4).Value Then
masterarray(i, 3) = sourcearray(j, 3).Value
Else
masterarray(i, 3).Value = ""
End If
Next
Next
End Sub
Function concatenate()
Dim nlastrow As Long
For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
Cells(i, "G").Value = Cells(i, "D").Value & "_" & Cells(i, "E").Value
Next i
Dim nnlastrow As Long
For i = 2 To Cells(Rows.Count, "H").End(xlUp).Row
Cells(i, "K").Value = Cells(i, "H").Value & "_" & Cells(i, "I").Value
Next i
End Function
Use variant arrays, that way you limit the number of calls to the sheet to only 3.
When your positive is found you need to exit the inner loop.
Sub createarray1()
Dim i As Long
Dim j As Long
Dim masterarray As Variant
Dim sourcearray As Variant
With ThisWorkbook.Worksheets("Sheet1") ' change to your sheet
masterarray = .Range("D3:G12")
sourcearray = .Range("H3:K26")
For i = LBound(masterarray, 1) To UBound(masterarray, 1)
masterarray(i, 3) = ""
For j = LBound(sourcearray, 1) To UBound(sourcearray, 1)
If masterarray(i, 4) = sourcearray(j, 4) Then
masterarray(i, 3) = sourcearray(j, 3)
Exit For
End If
Next j
Next i
.Range("D3:G12") = masterarray
End With
End Sub
But this can all be done with the following formula:
=INDEX(J:J,MATCH(G3,K:K,0))
Put it in F3 and copy/drag down.
I am having a sheet having seven cloumns. First six columns having either true or false and in last column I have to mention the heading of false cases in one statement. Below is the excel.
Excel sheet
I have tried if else statement but there are too many possibilities. Since I am new to VBA i don't know any shortcut to that.Any suggestions?.... Thanks
Try this simple vba code,
Sub TEXTJOIN()
Dim i As Long, str As String, k As Long, j As Long
str = ""
j = 0
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Application.WorksheetFunction.CountIf(Range("A" & i & ":F" & i), True) = 6 Then
Cells(i, 7) = "No Discrepancy Found"
Else
For k = 1 To 6
If Cells(i, k) = False Then
str = str & Cells(1, k) & ","
j = j + 1
End If
Next k
str = Left(str, Len(str) - 1) & " mismatch found"
Cells(i, 7) = Application.WorksheetFunction.Substitute(str, ",", " and ", j - 1)
str = ""
j = 0
End If
Next i
End Sub
Here's simple code which you should try:
Sub FindDiscrepancies()
Dim lastRow, i, j As Long
Dim discrepancies As String: discrepancies = ""
'find number of last row
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow
For j = 1 To 6
If LCase(Cells(i, j).Value) = "false" Then
discrepancies = discrepancies & Cells(1, j).Value & ", "
End If
Next j
If discrepancies = "" Then
Cells(i, 7).Value = "No discrepancies found"
Else
Cells(i, 7).Value = "Mismatch found in " & discrepancies
End If
discrepancies = ""
Next i
End Sub
How do i add dashes(-) til my cell value = 5, If my length character is not equal to five and i have a 4 character, for ex A B... what i want it to do if i have cell value less then 5 then i want it to replace with dashes(-) till my cell length value reach to 5 character. Here is my Code and image... IMAGE will make more sense.. let me know if there is any confusion.
Sub xn()
Dim x As Integer, lastrow As Long, a As Long, i As Long
Dim xcell As String
a = 1
lastrow = Worksheets("Sheet2").UsedRange.Rows.Count + 1
For i = a To lastrow
xcell = Worksheets("Sheet2").Range("A" & i).Value
Do Until Len(xcell) = 5
If Len(xcell) <> 5 Then
Worksheets("Sheet2").Range("C" & i) = Replace(xcell, " ", "_")
Else
Exit Do
End If
Loop
Next i
End Sub
try this
Sub test()
Dim lastrow&, i&, xcell$, z%
lastrow = Sheet2.Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To lastrow
xcell = Replace(Sheet2.Range("A" & i).Value, " ", "")
If Len(xcell) < 5 And xcell <> "" Then
z = 5 - Len(xcell)
Sheet2.Cells(i, "C").Value = Left(xcell, Len(xcell) - 1) & _
WorksheetFunction.Rept("-", z) & Right(xcell, 1)
Else
Sheet2.Cells(i, "C").Value = xcell
End If
Next i
End Sub
output
This line isn't going to do anything unless there's already spaces padding the end of the string:
Worksheets("Sheet2").Range("C" & i) = Replace(xcell, " ", "_")
You need to check the length, if it's less than five, add 5 - length characters to the end of it:
Sub xn()
Dim lastrow As Long
Dim i As Long
Dim xcell As String
lastrow = Worksheets("Sheet2").UsedRange.Rows.Count + 1
For i = 1 To lastrow
xcell = Worksheets("Sheet2").Range("A" & i).Value
If Len(xcell) < 5 Then
Worksheets("Sheet2").Range("C" & i) = xcell & String$(Len(xcell) - 5, "_")
End If
Next i
End Sub
You can also leave out the variable 'a' - it's basically a constant in the code you posted.