I'm trying to write a VBA script. This script would read 1 column and write the result in another column.
If the values are in bold or if is not blank, I would like to write the data in the column b1.
But if the values are not in bold, I would like to write the data in c1, and concatenate if I have 2 or more non-bold data in the same cell.
My code :
Sub Phone()
Dim valueLogon As String
Dim ValueDevice As String
Dim compteur As Integer
compteur = 1
For i = 1 To 2101
valueLogon = Range("A" & i)
If Range("A" & i).Font.bold = True And IsEmpty(valueLogon) = False Then
compteur = compteur + 1
Range("C" & i) = valueLogon
Else
Range("D" & compteur) = valueLogon & "," &
End If
Next i
End Sub
now, my result is like to the picture, but I would like concactenate the non-bold result in the same cell
change
Range("D" & compteur) = valueLogon & "," &
to
Range("D" & compteur).Value = valueLogon & "," & Range("D" & comptuer).Value
Related
I need to categorize my data into different buckets. my worksheet has column V & Column Y (actually a name match & address match respectively) has values that are either "ok" or "check". Column O has IDs, of which some are only numeric and some are alpha numeric.i need to fill my column A based on these 3 columns.
category 1 - Column A to be filled with "Verify name & Address" - logic for this is - If Column A is blank, Column V value = "check", Column Y value = "check" and column O = all alphanumeric IDs (except that starts with CWT) and numeric IDs = 2 & 9612
Category 2 - Column A to be filled with "Verify Address" - logic for this is - If Column A is blank, Column V value = "ok", Column Y value = "check" and column O = all alphanumeric IDs (except that starts with CWT) and numeric IDs = 2 & 9612.
Sub Rules()
'
'Autofill based on Rules
Worksheets("ORD_CS").Activate
Dim sht As Worksheet
Dim LR As Long
Dim i As Long
Set sht = ActiveWorkbook.Worksheets("ORD_CS")
LR = sht.UsedRange.Rows.Count
With sht
For i = 8 To LR
If .Range("A" & i).Value = "" And Range("V" & i).Value = "check" And Range("Y" & i).Value = "check" And Range("O" & i).Value = "2" And Range("O" & i).Value = "9612" Then
.Range("D" & i).Value = "Verify Name & Address"
End If
Next i
End With
End Sub
I have not completed my code. Can someone help? Thanks
The below should work, I changed your O column to be an OR
Edit: for function
Public Function IsAlpha(strValue As String) As Boolean
Dim intPos As Integer
For intPos = 1 To Len(strValue)
Select Case Asc(Mid(strValue, intPos, 1))
Case 65 To 90, 97 To 122
IsAlpha = True
Case Else
IsAlpha = False
Exit For
End Select
Next
End Function
With sht
For i = 8 To LR
If .Range("A" & i).Value = "" And Range("V" & i).Value = "check" And Range("Y" & i).Value = "check" And Range("O" & i).Value = "2" Or Range("O" & i).Value = "9612" Or IsAlpha(Range("O" & i).Value) = True Then
.Range("D" & i).Value = "Verify Name & Address"
Else
If .Range("A" & i).Value = "" AND .Range("V" & i).Value = "ok" AND .Range("O" & i).Value = "2" Or .Range("O" & i).Value = "9612" Then
Do Stuff
End If
End If
Next i
End With
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’m applying a formula:
Textual representation of formula:
=(SUBSTITUTE((LEFT(A2;(FIND("htt";A2;1))-3));";";";"))&RIGHT(A2;(LEN(A2)-(FIND("htt";A2;1))+3))
to all cells in a range A2:A10, writing a result to range B2:B10 respectively.
To do this I use the following macro:
Sub ColumnsFormat()
Dim s As String
Dim i As Integer, j As Integer
'Set wb = Workbooks("CSV_File.xlsm")
Application.ScreenUpdating = False
j = 1
For i = 2 To 10
s = "=(SUBSTITUTE((LEFT(R[" & Trim(Str(i)) & "]C[" & Trim(Str(j - 2)) & "],(FIND(""htt"",R[" & Trim(Str(i)) & "]C[" & Trim(Str(j - 2)) & "],1))-3)),"","","";""))&RIGHT(R[" & Trim(Str(i)) & "]C[" & Trim(Str(j - 2)) & "],(LEN(R[" & Trim(Str(i)) & "]C[" & Trim(Str(j - 2)) & "])-(FIND(""htt"",R[" & Trim(Str(i)) & "]C[" & Trim(Str(j - 2)) & "],1))+3))"
Sheets("Sheet1").Cells(i, 2).Value = s
Next i
End Sub
The problem is that for some reason a row number inside the formula inside a For cycle is wrong. Instead of taking A2; A3; A4 … A10 cells, (changing row number by 1 each time), macro runs through A2; A4; A6 etc. (increasing a row number by 2 each time).
What am I doing wrong?
By changing the row in the formula to 0 the code works just fine. I guess the problem is that in your formula the row was calculated relative to the specific cell the formula was afterwards applied to. Therefore the formula in B2 looked at A(2+2), in B3 at A(3+3) and so on.
Sub ColumnsFormat()
Dim s As String
Dim i As Integer, j As Integer
'Set wb = Workbooks("CSV_File.xlsm")
Application.ScreenUpdating = False
j = 1
For i = 2 To 10
s = "=(SUBSTITUTE((LEFT(R[" & 0 & "]C[" & j - 2 & "],(FIND(""htt"",R[" & 0 & "]C[" & Trim(Str(j - 2)) & "],1))-3)),"","","";""))&RIGHT(R[" & 0 & "]C[" & Trim(Str(j - 2)) & "],(LEN(R[" & 0 & "]C[" & Trim(Str(j - 2)) & "])-(FIND(""htt"",R[" & 0 & "]C[" & Trim(Str(j - 2)) & "],1))+3))"
Sheets("Sheet1").Cells(i, 2).Value = s
Next i
End Sub
I have some code which is designed to scan Columns F & G for occurrences of words found in an array, the array containing text found in Column J. If it finds occurrences in either Column F or Column G, it will copy and paste the terms into the corresponding columns.
Column J contains free text from a field in SAP. The field is free text so it could be "Kerry John Pub Expenses" or "CATS O/H Kerry John", or even "CATS John Kerry O/H". There is no data entry standard for this field; this is what makes this task difficult .
Column F and Column G contains first names and last names. The code makes an assumption, if it finds an entry in column F or G that matches an entry in the txt array, it will copy and paste that entry.
During testing, the code proved not sufficient to match the outcomes which I was looking for, and the solution to this problem would be to match text in Columns F and G concurrently for two matching words rather than doing them in separate intervals.
I would like some suggestions as to how this code could be re-written to achieve this result.
Example of successful code run
Here we have 4 rows of data, John Citizen is located in Row 3, therefore the blank cells in Columns F and G, Row 2 can be populated with his first and last name.
The problem
Because I have two rows that contain Kerry Citizen and John Kerry, the row is populated with Kerry Kerry as a result, where the entry should be "John" in Column F and "Kerry" in Column G
Code starts here
Sub arraycolumnmatch()
Dim txtArray As Variant, T As Variant
Dim I As Long, J As Long
For I = 2 To Range("E50000").End(xlUp).row
typ = Range("F" & I).Value
If typ = "" Then
txt = Range("J" & I).Value
txtArray = Split(txt, " ")
For Each T In txtArray
For J = 2 To Range("F50000").End(xlUp).row
If Range("F" & J).Value = T Then
match_txt = T
Range("F" & I).Value = match_txt
End If
Next J
Next T
For Each T In txtArray
For J = 2 To Range("G50000").End(xlUp).row
If Range("G" & J).Value = T Then
match_txt = T
Range("G" & I).Value = match_txt
End If
Next J
Next T
End If
Next I
End Sub
You can simplify your code greatly, and make it work, like this:
typ = Range("F" & I).Value
If typ = "" Then
txt = Range("J" & I).Value
matchFound = False
For J = 2 To Range("G50000").End(xlUp).Row
If InStr(txt, Range("F" & J).Value) <> 0 _
And InStr(txt, Range("G" & J).Value) _
And Not (IsEmpty(Range("F" & J).Value)) _
And Not (IsEmpty(Range("G" & J).Value)) Then
'Both names match. Copy them.
Range("F" & I).Value = Range("F" & J).Value
Range("G" & I).Value = Range("G" & J).Value
matchFound = True
Exit For ' look no further.
End If
Next J
If Not matchFound Then MsgBox "No match found for: " & txt
End If
Tested, works for me.
The Code below runs for every first name on the list but only adds the name if both names match.
Sub arraycolumnmatch()
Dim txtArray As Variant, t As Variant
Dim I As Long, J As Long
For I = 2 To Range("G50000").End(xlUp).Row
typ = Range("F" & I).Value
If typ = "" And Not Range("J" & I).Value = Empty Then
txt = Range("J" & I).Value
txtArray = Split(txt, " ")
For Each word In txtArray
If Not word = "" Then
Set findtext = Range("F:F").Find _
(what:=(word), LookIn:=xlValues)
stoploop = False
loopcnt = 0
Do While Not findtext Is Nothing And stoploop = False And loopcnt < 21
loopcnt = loopcnt + 1
If InStr(txt, Range("F" & findtext.Row).Value) <> 0 _
And InStr(txt, Range("G" & findtext.Row).Value) Then
'Both names match. Copy them.
Range("F" & I).Value = Range("F" & findtext.Row).Value
Range("G" & I).Value = Range("G" & findtext.Row).Value
stoploop = True
Exit For ' look no further.
Else
Set findtext = Range("F" & findtext.Row & ":F" & 50000).Find _
(what:=(word), LookIn:=xlValues)
End If
Loop
End If
Next word
If Not stoploop Then MsgBox "No match found for: " & txt
End If
Next I
End Sub
Edit: Did an integration of #Jean InStr and a Find in Range which would allow for less loop time and a double match find.
I have had to stick with my original syntax, answer is below. Not the most efficient way of reaching the result, but it works
Sub arraycolumnmatch()
Dim txtArray As Variant, T As Variant
Dim I As Long, J As Long
For I = 2 To Range("E50000").End(xlUp).row
typ = Range("F" & I).Value
If typ = "" Then
txt = Range("J" & I).Value
txtArray = Split(txt, " ")
For Each T In txtArray
For J = 2 To Range("G50000").End(xlUp).row
If Range("G" & J).Value = T Then
match_txt = T
Range("G" & I).Value = match_txt
Exit For
End If
Next J
Next T
For Each T In txtArray
For J = 2 To Range("F50000").End(xlUp).row
If Range("F" & J).Value = T Then
match_txt = T
If Not Range("G" & I).Value = T Then
Range("F" & I).Value = match_txt
Exit For
End If
End If
Next J
Next T
End If
Next I
I have a loop that runs through the worksheet and keeps track of works where the guy is named "bill" then memorizes those rows and i want to copy them over to the next sheet.
my problem is that
'works
'Range("525:525,504:504,502:502,497:497,496:496,495:495,494:494,493:493,492:492,491:491,478:478,471:471,453:453,450:450,449:449,448:448,447:447,446:446,445:445,444:444,443:443,442:442,441:441,440:440,439:439,438:438,437:437,436:436,427:427,129:129").Select
but when i use a variable to create that list of rows, it doesnt select the rows
Dim accountsArray(2, 2) As String
accountsArray(1, 0) = "test"
accountsArray(1, 1) = "bill"
Dim rngCounter As String
rngCounter = Chr(34)
For i = ActiveSheet.Cells(ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row, 1).Row To 2 Step -1
'save rows with bill
If InStr((ActiveSheet.Cells(i, 2).Text), accountsArray(1, 1)) <> 0 Then
If Len(rngCounter) < 2 Then rngCounter = rngCounter & i & ":" & i Else rngCounter = rngCounter & "," & i & ":" & i
End If
Next i
rngCounter = rngCounter & Chr(34)
'works
'Range("525:525,504:504,502:502,497:497,496:496,495:495,494:494,493:493,492:492,491:491,478:478,471:471,453:453,450:450,449:449,448:448,447:447,446:446,445:445,444:444,443:443,442:442,441:441,440:440,439:439,438:438,437:437,436:436,427:427,129:129").Select
'does not work
Range(rngCounter).Select
Selection.Copy
Sheets.Add after:=ActiveSheet
ActiveSheet.Paste
The way the code currently is written you're effectively calling this:
Range("""525:525,504:504,502:502,497:497,496:496,495:495,494:494,493:493,492:492,491:491,478:478,471:471,453:453,450:450,449:449,448:448,447:447,446:446,445:445,444:444,443:443,442:442,441:441,440:440,439:439,438:438,437:437,436:436,427:427,129:129""").Select
So take out the Chr(34) (double quotes) that you are adding to the beginning and end of your string and it'll work fine.