I am struggling with partial Match, the idea is to add a comment on each line if there is a match or not with the below row, result should be as on below picture
my struggle is with the part with Part Match, ex with B4 Value"87032610" and B5 "Payment 87032610", results which I want to have is txt in column C4 and C5 "Part Match"
so far my code :
Sub testRes()
Dim i As Integer
i = 2
Do While ThisWorkbook.Worksheets("test").cells(i, 1) <> ""
If ThisWorkbook.Sheets("test").cells(i, 1) Like "*" & ThisWorkbook.Sheets("test").cells(i + 1, 1) Then
ThisWorkbook.Sheets("test").cells(i, 1).Offset(0, 1).Value = "Yes"
ThisWorkbook.Sheets("test").cells(i + 1, 1).Offset(0, 1).Value = "Yes"
Else
ThisWorkbook.Sheets("test").cells(i, 1).Offset(0, 1).Value = "No"
ThisWorkbook.Sheets("test").cells(i + 1, 1).Offset(0, 1).Value = "No"
End If
i = i + 1
Loop
End Sub
Thank you :-)
Check variable payment texts against invoice number
It's less time consuming to loop through an array than cells by means of VBA. In order to check for partial findings just change the direction of Like comparisons (completed by surrounding wildcards *), as the invoice number represents the smaller part than variable payment texts (of commercial clients).
Sub testRes()
'[0]get variant 1-based 2-dim data field array
Dim rng As Range
Set rng = Sheet1.Range("B2:B9") ' << change to wanted range reference
Dim v
v = rng.Value
'[1]check invoice number against changing payment texts
Dim i As Long
Dim invoice, pmt
For i = 1 To UBound(v) - 1 Step 2
invoice = v(i, 1)
pmt = v(i + 1, 1)
If invoice = pmt Then
v(i, 1) = "Yes"
ElseIf pmt Like "*" & invoice & "*" Then
v(i, 1) = "Part Match"
Else
v(i, 1) = "No"
End If
v(i + 1, 1) = v(i, 1)
Next i
'[2]write results
rng.Offset(0, 1) = v
End Sub
Related
This is my
current data
I want to seperate the values ; (number)-(number) monate,(number)-(number) Teilnehmer,(number)monate,1
desired output
.
The data in all rows have different length and character. The values that i want to seperate is also have same structure but different values. There are over 3000 Rows I can't do that all manually
Your source data looks a little too complex for a straight forward text to columns.
Without a sample selection of input data, it's very difficult to test. Ideally, you should paste in several lines of sample data, showing each variation possible.
This untested code below might give you what you want. You just need to select the data (not the whole column) and then run the macro:
Sub try_this()
Dim s(1 To 4), c As Range, arrWords()
arrWords = Array("lzeit ", "Bildungsgutschein", "Teilnehmer")
For Each c In Selection.Cells
'look at start of string
If IsNumeric(Left(c.Value, 1)) Then
s(1) = 10 ' length of date
Else
s(1) = 19 ' length of non-date
End If
'write first section to cell to right
c.Offset(, 1).Value = Trim(Left(c.Value, s(1)))
'find Vollzeit/Teilzeit
s(2) = InStr(s(1), c.Value, arrWords(0)) - 3
'write duration to next cell on right
c.Offset(, 2).Value = Trim(Mid(c.Value, s(1) + 1, s(2) - s(1) - 1))
'write Vollzeit/Teilzeit to next cell on right
c.Offset(, 3).Value = Trim(Mid(c.Value, s(2), 8))
'find end of Bildungsgutschein
s(3) = InStr(1, c.Value, arrWords(1)) + Len(arrWords(1))
'write remainder of string to next cell on right
c.Offset(, 4).Value = Trim(Mid(c.Value, s(2) + 8, s(3) - s(2) - 8))
'find end of Teilnehmer
s(4) = InStr(1, c.Value, arrWords(2)) + Len(arrWords(2))
'if that word isn't found, reuse previous start point
If s(4) = Len(arrWords(2)) Then s(4) = s(3)
'write remainder of string to next cell on right
c.Offset(, 5).Value = Trim(Mid(c.Value, s(3), s(4) - s(3)))
'write remainder of string to next cell on right
c.Offset(, 6).Value = Trim(Mid(c.Value, s(4)))
Next
End Sub
I have written a simple VBA script (code below) that should inspect every cell in a certain column. Here I want to do some string manipulation ( i wante to search for "." in the string and then take the right side, but because I could not get it to work I always take the 4 digit as a start). I then copy the manipulated string into another cell and later back. The code works, but for some reason, it takes ages to run on only 35 cells!
I´m still a kook on VBA and wanted to get input what could be the reason for it and what I could improve to get a faster runtime. Is it because I take all strings froms 4 up to 50 ?
Sub EditStatus()
Application.DisplayAlerts = False
ActiveSheet.Name = "Backend"
myNum = Application.InputBox("Please enter the row number until which you would like to update the status column (only for new entries)")
For i = 2 To myNum
Cells(i, 20).Value = Mid(Cells(i, 10), 4, 50)
Cells(i, 10).Value = Cells(i, 20).Value
Next i
Range("T1:T200").Clear
Application.DisplayAlerts = True
End Sub
Thanks
No need for a loop. You can enter the formula in the entire range in 1 go and then convert them to values before putting the values back in Col J
Replace
For i = 2 To myNum
Cells(i, 20).Value = Mid(Cells(i, 10), 4, 50)
Cells(i, 10).Value = Cells(i, 20).Value
Next i
With
With Range("T2:T" & myNum)
.Formula = "=MID(J2, 4, 50)"
.Value = .Value
Range("J2:J" & myNum).Value = .Value
End With
Alternatively, you can directly perform the same action in Col J without the helper column T. For example you can do all that in 1 line as explained HERE as well
Simply replace
For i = 2 To myNum
Cells(i, 20).Value = Mid(Cells(i, 10), 4, 50)
Cells(i, 10).Value = Cells(i, 20).Value
Next i
Range("T1:T200").Clear
with
Range("J2:J" & myNum).Value = Evaluate("Index(MID(" & "J2:J" & myNum & ", 4, 50),)")
Replace Values In-Place
Adjust the values in the constants section.
This solution overwrites the data and doesn't use a helper column, but you can test it with one indicated near the end of the code.
Solve the renaming (Backend) part as needed.
The Code
Option Explicit
Sub EditStatus()
' Define constants.
Const sPrompt As String = "Please enter the row number until which you " _
& "would like to update the status column (only for new entries)"
Const sTitle As String = "Enter Number"
Const wsName As String = "Backend"
Const First As Long = 2
Const cCol As Long = 10 ' J
Const Delim As String = "."
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
' Require input.
Dim Last As Variant
Last = Application.InputBox( _
Prompt:=sPrompt, Title:=sTitle, Default:=First, Type:=1)
' Validate input.
If VarType(Last) = vbBoolean Then
MsgBox "You cancelled."
Exit Sub
End If
If Last < First Then
MsgBox "Enter a number greater than " & First - 1 & "."
Exit Sub
End If
If Int(Last) <> Last Then
MsgBox "Enter a WHOLE number greater than " & First - 1 & "."
Exit Sub
End If
' Define column range.
Dim rg As Range
Set rg = wb.Worksheets(wsName).Cells(First, cCol).Resize(Last - First + 1)
' Write values from column range to array.
Dim Data As Variant
If rg.Rows.Count > 1 Then
Data = rg.Value
Else
ReDim Data(1 To 1, 1 To 1): Data = rg.Value
End If
' Declare additional variables
Dim cValue As Variant ' Current Value
Dim i As Long ' Current Row (Array Row Counter)
Dim fPos As Long ' Current Delimiter Position
' Replace strings containing the delimiter, with the sub string
' to the right of it.
For i = 1 To UBound(Data)
cValue = Data(i, 1)
If Not IsError(cValue) Then
fPos = InStr(1, cValue, Delim)
If fPos > 0 Then
Data(i, 1) = Right(cValue, Len(cValue) - fPos)
End If
End If
Next i
' Maybe rather test with the following (writes to column 20 ("T")).
'rg.Offset(, 10).Value = Data
' Write values from array to column range.
rg.Value = Data
End Sub
I have a table as shown below,based on yellow highlighted column i need to sum green highlighted columns.
Expected output is here:
I have done it using the below code …
Sub test()
lrow = ActiveSheet.Cells(ActiveSheet.Cells.Rows.Count, 1).End(xlUp).Row
Set Rng = Range("A2:A" & lrow)
For Each cell In Rng
If Not IsEmpty(cell) Then
a = cell
b = cell.Offset(0, 1)
c = cell.Offset(0, 5)
r = cell.Row
cnt = Application.WorksheetFunction.CountIf(Rng, cell)
d = 0
For i = 1 To cnt
If Cells(r + i, 1) = a And Cells(r + i, 2) = b And Cells(r + i, 6) Then
Cells(r, 7) = Cells(r + i, 7) + Cells(r, 7)
Cells(r, 8) = Cells(r + i, 8) + Cells(r, 8)
d = d + 1
End If
Next
If d > 0 Then Range(Cells(r + 1, 1).Address, Cells(r + d, 1).Address).EntireRow.Delete
End If
Next
End Sub
I want to do it using scripting dictionary, which is new for me. Since I'm a beginner, I'm unable to modify the below example code found in net!!
Got it from here
Sub MG02Sep59()
Dim Rng As Range, Dn As Range, n As Long, nRng As Range
Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
If Not .Exists(Dn.Value) Then
.Add Dn.Value, Dn
Else
If nRng Is Nothing Then Set nRng = Dn Else Set nRng = Union(nRng, Dn)
.Item(Dn.Value).Offset(, 3) = .Item(Dn.Value).Offset(, 3) + Dn.Offset(, 3)
End If
Next
If Not nRng Is Nothing Then nRng.EntireRow.Delete
End With
End Sub
Can anyone help me out? with some notes if possible.
this is how I would do it:
Option Explicit
Sub Test()
Dim ws As Worksheet
Dim arrData As Variant
Dim i As Long, ConcatenateStr As String, Sum1 As Currency, Sum2 As Currency
Dim DictSum1 As Scripting.Dictionary 'You need the Microsoft Scripting Runtime reference for this to work
Dim DictSum2 As Scripting.Dictionary
Set ws = ThisWorkbook.Sheets("SheetName") 'Change this to fit your sheet name
Set DictSum1 = New Scripting.Dictionary 'This is how you initialize your dictionary
Set DictSum2 = New Scripting.Dictionary
'Store everything on your sheet into the array
arrData = ws.UsedRange.Value 'this will get from A1 till ctrl+end cell I'd delete rows and columns that are blank
'Loop through the array to fill the dictionary
For i = 2 To UBound(arrData) '2 because row 1 are headers, UBound is the function to get the last item of your array like .count
If arrData(i, 1) = vbNullString Then Exit For 'this will end the loop once finding an empty value on column A
ConcatenateStr = arrData(i, 1) & arrData(i, 2) & arrData(i, 3) & arrData(i, 6) 'this is to work cleaner, each number is the number of the column concatenated
Sum1 = arrData(i, 7) 'column Sum 1
Sum2 = arrData(i, 8) 'column Sum 2
If Not DictSum1.Exists(ConcatenateStr) Then 'For the column Sum 1
DictSum1.Add ConcatenateStr, Sum1 'this will add the first item Key = Concatenate String and item = the money value
Else
DictSum1(ConcatenateStr) = DictSum1(ConcatenateStr) + Sum1 'this will sum the existing value on the dictionary + the current value of the loop
End If
If Not DictSum2.Exists(ConcatenateStr) Then 'For the column Sum 2
DictSum2.Add ConcatenateStr, Sum2 'this will add the first item Key = Concatenate String and item = the money value
Else
DictSum2(ConcatenateStr) = DictSum2(ConcatenateStr) + Sum2 'this will sum the existing value on the dictionary + the current value of the loop
End If
Next i
Erase arrData
With ws
.UsedRange.RemoveDuplicates Columns:=Array(1, 2, 3, 6), Header:=xlYes 'Again UsedRange will take everything, Columns as you can see are the ones highlighted in yellow
arrData = .UsedRange.Value 'Store the results of deleting all the duplicates
For i = 2 To UBound(arrData) 'Lets fill the array with the sums
ConcatenateStr = arrData(i, 1) & arrData(i, 2) & arrData(i, 3) & arrData(i, 6)
arrData(i, 8) = DictSum1(ConcatenateStr)
arrData(i, 9) = DictSum2(ConcatenateStr)
Next i
.UsedRange.Value = arrData 'Paste back the array with all the sums
End With
End Sub
I've commented the code, but to learn more about dictionaries check this awesome tutorial
I have created a nested for loop to compare 3 different cell values within 2 sheets. The loop works fine when the data is small, but when I run on 5,000 rows its too slow and crashes excel. Any idea of how to run this more efficiently.
Sub RowMatch()
Dim x As Integer
' Make sure we are in the right sheet
Worksheets("Q416").Activate
' Set numrows = number of rows of data.
NumRows = Range("C2", Range("C2").End(xlDown)).Rows.count
' find the reference range
Worksheets("Q415").Activate
NumRows2 = Range("C5", Range("C5").End(xlDown)).Rows.count
Worksheets("Q416").Activate
MsgBox ("Total # of Rows on this sheet = " & NumRows & " and " & NumRows2 & " in Ref Range")
Range("A1").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
'MsgBox NumRows2
For y = 1 To NumRows2
'MsgBox (ActiveCell.Offset(x, 0).Value & " & " & Worksheets("Q415").Cells(y + 1, 1))
If ActiveCell.Offset(x, 0).Value = Worksheets("Q415").Cells(y + 1, 1).Value _
And ActiveCell.Offset(x, 2).Value = Worksheets("Q415").Cells(y + 1, 3).Value Then
If ActiveCell.Offset(x, 5).Value = Worksheets("Q415").Cells(y + 1, 6).Value Then
'If NumRows(i).Value = ActiveCell.Offset(1, 0).Value Then
ActiveCell.Offset(x, 10).Value = "Same"
Else
ActiveCell.Offset(x, 10).Value = ActiveCell.Offset(x, 5).Value - Worksheets("Q415").Cells(y + 1, 6).Value
End If
End If
Next y
Next x
End Sub
Reading and writing to cells is one of the slowest operations you can do in Excel VBA. Instead, you should place the values contained in the worksheets into arrays and work with them there, Here is an excellent reference: http://www.cpearson.com/excel/ArraysAndRanges.aspx. Use your NumRows variables and either a column letter or number to define the ranges that will consitute the arrays e.g:
myRange = Range("A1:C" & NumRows)
myArray = myRange.value
From the link to Chip Pearsons site:
Dim Arr() As Variant
Arr = Range("A1:B10")
Dim R As Long
Dim C As Long
For R = 1 To UBound(Arr, 1) ' First array dimension is rows.
For C = 1 To UBound(Arr, 2) ' Second array dimension is columns.
Debug.Print Arr(R, C)
Next C
Next R
My code mostly works but it's taking a while to debug so I am beginning to think my architecture may be flawed XD So how can I architect this better?
I have groups of data separated by a blank row. You can tell each group apart by the ID in column C in addition to the blank row. For each ID, I have various numbers in column B that I need to capture. Sometimes those numbers only start with 5, sometimes it starts with 7. I need to capture the 5 and the 7 separately.
With projWS
With .Range("C1:C6000")
Set f = .Find(cc, LookIn:=xlValues, lookat:=xlPart)
End With
If Not f Is Nothing Then 'first occurence found
counter = 0
i = f.Row
Do
acct = .Cells(i, 2)
If (Len(projWS.Cells(i, 3)) < 1 Or Left(acct, 1) = "7") And done = False Then
acctStart = f.Row
acctRows = i - acctStart
Set acctRng = .Range(.Cells(acctStart, 2), .Cells(i - 1, 5))
Set amountRng = .Range(.Cells(acctStart, 7), .Cells(i - 1, 8))
done = True 'set flag to show range has been filled
End If
counter = counter + 1 'increment counter
i = i + 1 'move to next row
Loop Until Len(.Cells(i, 3)) < 1 'keep looping until blank row
End If
If counter - 1 > acctRows Then 'how we determine if there's a "7"
flag = True 'so we set flag to true
Set depreRng = Range(.Cells(acctStart + acctRows, 2), .Cells(i - 1, 8))
dep = depreRng.Value2 'store range into array
End If
End With
After capture, I need to drop it into another worksheet. This worksheet already has a block of 7 built in. Hence this is the loop I am using to drop the range of 7. There is no built in block for the 5.
For r = 112 To 120
For k = 1 To UBound(dep())
If .Cells(r, 1).Value2 = Trim(dep(k, 1)) Then
Debug.Print .Cells(r, 1).Value2
.Cells(r, 6) = dep(k, 6)
.Cells(r, 7) = dep(k, 7)
Exit For
Else
.Cells(r, 6) = 0
.Cells(r, 7) = 0
End If
Next k
Next r
I have debugged several errors already. The current one is that depreRng is breaking because my math is bad. Instead of debugging each error as I stumble onto it, how can I architect this better?
Ok, my approach it's different. First i use a filter for find the range of rows with the index you are looking for and then loop inside this filtered rows for find the 5xx and the 7xx range. The code:
Sub Macro1()
Dim rng_5xx_start, rng_5xx_stop, rng_7xx_start, rng_7xx_stop As Integer
rng_5xx_start = 0
rng_5xx_stop = 0
rng_7xx_start = 0
rng_7xx_stop = 0
Dim range_5xx, range_7xx As String
'filter for the index you are looking for
'specify the maximum range, the field is the "offset" from the column B (the firts of the range), so for filter for column C you need to put 2, criteria...is the critera :)
ActiveSheet.Range("$B$1:$H$6000").AutoFilter Field:=2, Criteria1:="b"
'the filter returns only the rows with the specifyed index, now a for inside this rows for find the 5xx and the 7xx sub-ranges
For Each Row In ActiveSheet.Range("b1:b6000").SpecialCells(xlCellTypeVisible)
If Cells(Row.Row, 2).Value > 4999 And Cells(Row.Row, 2).Value < 6000 Then
'or any test for understnd if i'm in the 5xx range, if you prefer use the strings use something like left(cells(row.row,2).value,1) = "5"
If rng_5xx_start = 0 Then 'found the first row with a 5xx value
rng_5xx_start = Row.Row 'set the start of the range to this row
End If
If rng_5xx_stop < Row.Row Then 'the row where i am is in the 5xx range and is grater than the current end i noticed
rng_5xx_stop = Row.Row 'refresh the end of the range...at the end this will have the last number of row of the 5xx range
End If
End If
If Cells(Row.Row, 2).Value > 6999 And Cells(Row.Row, 2).Value < 8000 Then
'same as above but for 7xx range
If rng_7xx_start = 0 Then
rng_7xx_start = Row.Row
End If
If rng_7xx_stop < Row.Row Then
rng_7xx_stop = Row.Row
End If
End If
Next
If rng_5xx_start = 0 Then
'not found 5xx rows
range_5xx = "" 'or False, or what you prefer...
Else
range_5xx = "B" & rng_5xx_start & ":H" & rng_5xx_stop
End If
If rng_7xx_start = 0 Then
'not found 7xx rows
range_7xx = "" 'or False, or what you prefer...
Else
range_7xx = "B" & rng_7xx_start & ":H" & rng_7xx_stop
End If
End Sub
That's how i would imagine a macro for your job ;)
Edit 1:
I forgot that this will leave the sheet with the filter on...use activesheet.showalldata for show all the rows and not only the filtered ones
Edit 2:
The tests
If rng_5xx_stop < Row.Row Then
rng_5xx_stop = Row.Row
End If
and
If rng_7xx_stop < Row.Row Then
rng_7xx_stop = Row.Row
End If
are not necessary, it's enough do rng_5xx_stop = Row.Row and rng_7xx_stop = Row.Row and save the two IF statements
You are grouping cells based on the first number of the cell values in column B (I am assuming that they can never be letters). If that is the case, then you can create an array of 0 to 9 and store your ranges in there. Then go through the range.areas in order to get the groupings you're looking for (as highlighted in your screenshot).
To do this, something like this is all you need. I commented code to try to explain it more:
Sub tgr()
Dim wsData As Worksheet
Dim rColB As Range
Dim BCell As Range
Dim aRanges(0 To 9) As Range
Dim SubGroup As Range
Dim lRangeNum As Long
Dim i As Long
'Change to your actual worksheet
Set wsData = ActiveWorkbook.ActiveSheet
'Change to your actual column range, this is based off the sample data
Set rColB = wsData.Range("B1", wsData.Cells(wsData.Rows.Count, "B").End(xlUp))
'Loop through the column range
For Each BCell In rColB.Cells
'Make sure the cell is populated and the starting character is numeric
If Len(BCell.Value) > 0 And IsNumeric(Left(BCell.Value, 1)) Then
'Get the starting digit
lRangeNum = Val(Left(BCell.Value, 1))
'Check if any ranges have been assigned to that array index location
'If not, start a range at that array index
'If so, combine the ranges with Union
Select Case (aRanges(lRangeNum) Is Nothing)
Case True: Set aRanges(lRangeNum) = BCell
Case Else: Set aRanges(lRangeNum) = Union(aRanges(lRangeNum), BCell)
End Select
End If
Next BCell
'You can use any method you want to access the ranges, this just loops
'through the array indices and displays the range areas of each
For i = 0 To 9
If Not aRanges(i) Is Nothing Then
For Each SubGroup In aRanges(i).Areas
'Do what you want with it here
'This just selects the subgroup so you can see it found the groups properly
SubGroup.Select
MsgBox SubGroup.Address
Next SubGroup
End If
Next i
End Sub
I see you've allready rewritten your code, but I'd like to offer how I would do it and would like to know your thoughts about it. Would this be inefficient? I guess it could be because you have to read the first character in cells 4 times for every increment, but not shure if that is a big problem.
Dim start_row As Long
Dim end_row As Long
start_row = 1
end_row = 0
For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
If Cells(i - 1, 2) = "" Then
start_row = i
ElseIf Left(Cells(i - 1, 2), 1) <> Left(Cells(i, 2), 1) Then
start_row = i
End If
If Cells(i + 1, 2) = "" Then
end_row = i
ElseIf Left(Cells(i + 1, 2), 1) <> Left(Cells(i, 2), 1) Then
end_row = i
End If
If end_row <> 0 Then
Call copy_range(start_row, end_row)
end_row = 0
End If
Next i
Another approach that lets you only read the character once could be
Dim start_row As Long
Dim end_row As Long
Dim char_above As String
Dim this_char As String
start_row = 1
end_row = 1
For i = 1 To Range("B" & Rows.Count).End(xlUp).Row
If Cells(i, 2) = "" Then
end_row = i - 1
if i <>1 then Call copy_range(start_row, end_row,char_above)
start_row = i + 1
Else
this_char = Left(Cells(i, 2), 1)
If this_char <> char_above Then
end_row = i - 1
if i<> 1 then Call copy_range(start_row, end_row,char_above)
start_row = i
End If
char_above = this_char
End If
Next i
Let me know your thoughts.