I have this code below which I want to be used in a loop. However, instead of C5 and D5, I would want this loop to be run on all the cells in column C and column D and not only for C5 and D5.
To summarize, I would want C5 and D5 to be replaced by every cell in Column C and D. Please assist.
For i = 1 To 5
Valuex = Evaluate("=IsNumber(Value(Mid(C5, 2, 1)))")
MsgBox (Valuex)
Valuex1 = Evaluate("=Left(Trim(C5), 1) = ""R""")
MsgBox (Valuex1)
If ((Evaluate("=Left(Trim(C5), 1) = ""R""") = "True") And (Evaluate("=IsNumber(Value(Mid(C5, 2, 1)))") = "True")) Then
Range("D5").Formula = "=VLOOKUP(C5,[old.xls]Sheet1!$D:$V,19,0)"
MsgBox ("if")
Else
Range("D5").Formula = "=VLOOKUP(C5,[old.xls]Sheet1!$E:$V,18,0)"
MsgBox ("else")
End If
Next i
Think this does what you want. It will run from row 1 to the last row in C. Note that you could do all this without VBA.
Sub x()
Dim i As Long, Valuex As Boolean, Valuex1 As Boolean
For i = 1 To Range("C" & Rows.Count).End(xlUp).Row
Valuex = Evaluate("=IsNumber(Value(Mid(C" & i & ", 2, 1)))")
MsgBox (Valuex)
Valuex1 = Evaluate("=Left(Trim(C" & i & "), 1) = ""R""")
MsgBox (Valuex1)
If Valuex1 And Valuex Then
Range("D" & i).Formula = "=VLOOKUP(C" & i & ",[old.xls]Sheet1!$D:$V,19,0)"
MsgBox ("if")
Else
Range("D" & i).Formula = "=VLOOKUP(C" & i & ",[old.xls]Sheet1!$E:$V,18,0)"
MsgBox ("else")
End If
Next i
End Sub
I think you can avoid the loop altogether thus
Sub xx()
Dim i As Long
i = Range("C" & Rows.Count).End(xlUp).Row
With Range("D1:D" & i)
.Formula = "=IF(AND(ISNUMBER(VALUE(MID(C1, 2, 1))),LEFT(TRIM(C1), 1) = ""R""),VLOOKUP(C1,Sheet1!$D:$V,19,0),VLOOKUP(C1,Sheet1!$E:$V,18,0))"
.Value = .Value
End With
End Sub
Related
I have a task that requires me to reconcile two sheets of data. I have reformatted them both to have the same format from Column A to M and use the below code to run the reconciliation
It is fine when the data is small but when it gets to thousands of lines, it took 30 min just to run. Is there a way to optimize this code?
The idea is reconcile 2 worksheets then all the matched data go to the 'Matched' worksheet and the unmatched goes to the unmatched worksheet
Dim report_exLR As Long
Dim report_inLR As Long
Dim report_exrng As Range
Dim report_inrng As Range
Set ws_rexternal = ThisWorkbook.Worksheets("Reformat External")
Set ws_rinternal = ThisWorkbook.Worksheets("Reformat Internal")
Set ws_unmatched = ThisWorkbook.Worksheets("Unmatched")
Set ws_matched = ThisWorkbook.Worksheets("Matched")
ex_LR = ws_rexternal.Cells(Rows.Count, 2).End(xlUp).Row
in_LR = ws_rinternal.Cells(Rows.Count, 2).End(xlUp).Row
'concatenate all relevant criteria into one column
For a = 2 To ex_LR
ws_rexternal.Range("T" & a) = ws_rexternal.Range("A" & a) & "," & ws_rexternal.Range("B" & a) & "," & ws_rexternal.Range("C" & a) & "," & ws_rexternal.Range("D" & a) & "," & ws_rexternal.Range("E" & a) & "," & ws_rexternal.Range("F" & a) & "," & ws_rexternal.Range("G" & a) & "," & ws_rexternal.Range("H" & a) & "," & ws_rexternal.Range("I" & a) & "," & ws_rexternal.Range("J" & a) & "," & ws_rexternal.Range("K" & a) & "," & ws_rexternal.Range("L" & a) & "," & ws_rexternal.Range("M" & a)
Next a
For b = 2 To ex_LR
ws_rinternal.Range("T" & b) = ws_rexternal.Range("A" & b) & "," & ws_rexternal.Range("B" & b) & "," & ws_rexternal.Range("C" & b) & "," & ws_rexternal.Range("D" & b) & "," & ws_rexternal.Range("E" & b) & "," & ws_rexternal.Range("F" & b) & "," & ws_rexternal.Range("G" & b) & "," & ws_rexternal.Range("H" & b) & "," & ws_rexternal.Range("I" & b) & "," & ws_rexternal.Range("J" & b) & "," & ws_rexternal.Range("K" & b) & "," & ws_rexternal.Range("L" & b) & "," & ws_rexternal.Range("M" & b)
Next b
'start reconciliation
For a = 2 To ex_LR
For b = 2 To in_LR
If ws_rexternal.Range("T" & a) = ws_rinternal.Range("T" & b) Then
ws_rexternal.Range(Cells(a, 1).Address, Cells(a, 14).Address).Copy Destination:=ws_matched.Range(Cells(a, 1).Address, Cells(a, 14).Address)
ws_rinternal.Range(Cells(b, 1).Address, Cells(b, 14).Address).Copy Destination:=ws_matched.Range(Cells(a, 16).Address, Cells(a, 30).Address)
ws_matched.Cells(a, 15).Value = "Matched"
ws_matched.Cells(a, 15).Interior.Color = RGB(0, 255, 0)
ws_rexternal.Rows(a).ClearContents
ws_rinternal.Rows(b).ClearContents
End If
Next b
Next a
'reformat the unmatched and matched
For d = ex_LR To 1 Step -1
Set ex_Row = ws_rexternal.Rows(d)
If WorksheetFunction.CountA(ex_Row) = 0 Then
ws_rexternal.Rows(d).Delete
End If
Next d
For e = in_LR To 1 Step -1
Set in_Row = ws_rinternal.Rows(e)
If WorksheetFunction.CountA(in_Row) = 0 Then
ws_rinternal.Rows(e).Delete
End If
Next e
report_exLR = ws_rexternal.Cells(Rows.Count, 2).End(xlUp).Row
report_inLR = ws_rinternal.Cells(Rows.Count, 2).End(xlUp).Row
Set report_exrng = ws_rexternal.Range("A1:A" & report_exLR)
report_exrng.EntireRow.Copy ws_unmatched.Cells(1, 1)
Set report_inrng = ws_rinternal.Range("A1:A" & report_inLR)
report_inrng.EntireRow.Copy ws_unmatched.Cells(ex_LR, 1).Offset(5, 0)
End Sub
Ok this is probably a lot more complex than it needs to be, but it seems to work OK.
It would be much simpler to just flag the data in-place as matched/unmatched, with a pointer to the matching row on the other sheet.
Sub FormatExcel()
Dim report_exLR As Long, ws_rexternal As Worksheet, ws_unmatched As Worksheet
Dim report_inLR As Long, ws_rinternal As Worksheet, ws_matched As Worksheet
Dim report_exrng As Range, report_inrng As Range
Dim rngInt As Range, rngExt As Range, k, rw As Range, t, rwMatch As Long
Dim rngIntKeys As Range, rngExtKeys As Range, m, rng As Range, n As Long
Dim rngUnmatchedInt As Range, rngUnmatchedExt As Range
Setup
t = Timer
With ThisWorkbook
Set ws_rexternal = .Worksheets("Reformat External")
Set ws_rinternal = .Worksheets("Reformat Internal")
Set ws_unmatched = .Worksheets("Unmatched")
Set ws_matched = .Worksheets("Matched")
End With
'clear previous data
ws_unmatched.Cells.Clear
ws_matched.Cells.Clear
'source data ranges
Set rngInt = ws_rinternal.Range("A2:M" & ws_rinternal.Cells(Rows.Count, 2).End(xlUp).Row)
Set rngExt = ws_rexternal.Range("A2:M" & ws_rexternal.Cells(Rows.Count, 2).End(xlUp).Row)
'speed up copy/paste
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'generate all keys for Internal rows in ColT
For Each rw In rngInt.Rows
rw.EntireRow.Columns("T").Value = RowKey(rw)
Next rw
Set rngIntKeys = rngInt.EntireRow.Columns("T") 'range with keys
Debug.Print "Generated keys", Timer - t
rwMatch = 1
For Each rw In rngExt.Rows
If rw.Row Mod 100 = 0 Then Debug.Print "Row: " & rw.Row, Timer - t
m = Application.Match(RowKey(rw), rngIntKeys, 0)
If Not IsError(m) Then 'got match on "internal" sheet?
rwMatch = rwMatch + 1
rw.Copy ws_matched.Cells(rwMatch, "A")
ws_matched.Cells(rwMatch, "N").Value = "Matched"
rngInt.Rows(m).Copy ws_matched.Cells(rwMatch, "P")
rngIntKeys.Cells(m).ClearContents 'remove matched key from T
Else
BuildRange rngUnmatchedExt, rw 'collect unmatched external row
End If
Next rw
Debug.Print "Copied matches", Timer - t
'copy unmatched external
If Not rngUnmatchedExt Is Nothing Then
rngUnmatchedExt.Copy ws_unmatched.Range("A1")
End If
'copy unmatched internal
Set rngIntKeys = rngInt.EntireRow.Columns("T")
For n = 1 To rngExt.Rows.Count
If Len(rngIntKeys.Cells(n).Value) > 0 Then
BuildRange rngUnmatchedInt, rngExt.Rows(n)
End If
Next n
If Not rngUnmatchedInt Is Nothing Then
rngUnmatchedInt.Copy _
ws_unmatched.Cells(ws_unmatched.UsedRange.Rows.Count + 5, 1)
End If
Debug.Print "Copied non-matches", Timer - t
Application.Calculation = xlCalculationAutomatic
End Sub
'generate a "key" by concatenating all cell values in `rng` with "|"
Function RowKey(rng As Range) As String
RowKey = Join(Application.Transpose(Application.Transpose(rng.Value)), "|")
End Function
'build up a range from sub-ranges
Sub BuildRange(ByRef rngTot As Range, rngAdd As Range)
If rngTot Is Nothing Then
Set rngTot = rngAdd
Else
Set rngTot = Application.Union(rngTot, rngAdd)
End If
End Sub
For completeness here's the sub I used to reset the sheets and create sample data:
'reset the sheets and create some sample data
Sub Setup()
Const ROWSN As Long = 1000 '# of rows to create
Const RNDV As String = "=ROUND(rand()*5,0)" 'adjust to change chance of matched rows
Dim ws_rexternal As Worksheet, ws_unmatched As Worksheet
Dim ws_rinternal As Worksheet, ws_matched As Worksheet
With ThisWorkbook
Set ws_rexternal = .Worksheets("Reformat External")
Set ws_rinternal = .Worksheets("Reformat Internal")
Set ws_unmatched = .Worksheets("Unmatched")
Set ws_matched = .Worksheets("Matched")
End With
'clar all sheets
ws_unmatched.Cells.Clear
ws_matched.Cells.Clear
ws_rexternal.Cells.Clear
ws_rinternal.Cells.Clear
'ws_rexternal.Range ("A2:M1000")
With ws_rexternal.Range("A2:C2").Resize(ROWSN)
.Formula = RNDV
.Value = .Value
End With
ws_rexternal.Range("D2:M2").Resize(ROWSN).Value = "blah"
With ws_rinternal.Range("A2:C2").Resize(ROWSN)
.Formula = RNDV
.Value = .Value
End With
ws_rinternal.Range("D2:M2").Resize(ROWSN).Value = "blah"
End Sub
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 was wondering if there is a way to split a cell with for example 6000 words into 1000 word pieces. So for example, 1000 words in cell C1, then the next 1000 words in C2 and so on.
Here is the code I have so far.
The output of that code (Cell C1) should be split, with C6 with 1000 words, C7 with 1000 words and so on until no more words are available.
Thank you in advance!
Option Explicit
Option Base 1
Dim dStr As String, aCell As Range
Dim cet, i As Long
Sub countWords()
Application.ScreenUpdating = False
Dim iniWords As Long, lWords As Long
Dim wK As Worksheet
On Error GoTo Err
Set wK = ActiveSheet
dStr = Join(WorksheetFunction.Transpose(wK.Range("A1:A" & wK.Range("A" & Rows.Count).End(xlUp).Row).Value), " ")
'iniWords = WorksheetFunction.CountA(wK.Range("A1:A" & wK.Rows.Count))
cet = Split(dStr, " ")
iniWords = UBound(cet)
wK.Range("A1:A" & wK.Range("A" & Rows.Count).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlNo
'lWords = WorksheetFunction.CountA(wK.Range("A1:A" & wK.Rows.Count))
dStr = Join(WorksheetFunction.Transpose(wK.Range("A1:A" & wK.Range("A" & Rows.Count).End(xlUp).Row).Value), " ")
cet = Split(dStr, " ")
dStr = ""
For i = LBound(cet) To UBound(cet)
If Trim(cet(i)) <> "" And InStr(dStr, Trim(cet(i))) = 0 Then
dStr = Trim(dStr) & " " & Trim(cet(i))
End If
Next i
dStr = Trim(dStr)
cet = Split(dStr, " ")
lWords = UBound(cet)
wK.Range("C1") = dStr
Application.ScreenUpdating = True
MsgBox "Words: " & iniWords & vbNewLine & _
"Removed duplicates " & iniWords - lWords & vbNewLine & _
"Remaining Words " & lWords
Exit Sub
Err:
MsgBox "There is no data in row A"
End Sub
you could use this:
Option Explicit
Sub main()
Const NWORDS As Long = 100 '<--| it's the number of words you want each cell to be written with. change it to your needs
Dim strng As String
Dim rowOffset As Long
With Range("C1")
strng = .Value
rowOffset = 5 '<--| point to C7 at the first iteration
Do
strng = Replace(strng, " ", "|", , NWORDS) '<--| "mark" the first NWORDS with a different separator (be sure pipe ("|") is not a character you can have in your words)
.Offset(rowOffset).Value = Replace(Left(strng, InStrRev(strng, "|") - 1), "|", " ") '<--| write first NWORDS words in current 'rowoffset' cell
strng = Right(strng, Len(strng) - InStrRev(strng, "|"))
rowOffset = rowOffset + 1 '<--| update row offset
Loop While UBound(Split(strng, " ")) > NWORDS - 1
.Offset(rowOffset).Value = strng
End With
End Sub
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
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