I have a collection of phone numbers in a column. I want to identify similar ones in the column. The similarity rule would be the first 8 digits are the same and the last two digits are in sequence (at least 3 numbers).
For example,
8601116612
8601116613
8601116614
The three numbers above should be identified as being similar. How can I do this in VBA?
Alrighty, this was kinda frustrating, but here it is:
Sub findSims()
Dim i, j, rc, rc1 As Double
Dim m, z As Double
i = 1
m = 0
z = 0
Do While Cells(i, 1) <> ""
' calculate the value of the last two digits
' for educational reasons one calculation
rc = Right(Cells(i, 1), 2)
rc1 = Right(Cells(i + 1, 1), 2) - 1
' .. and one direct comparation ..
' .. of the first 8 digits and afterwards the first two
If Left(Cells(i, 1), 8) = Left(Cells(i + 1, 1), 8) Then
If rc = rc1 Then
' there are two counters because we have to wait until we have three similar numbers
m = m + 1
z = z + 1
Else
' if the similarities stop, we kill m
m = 0
' we use z to write this cutie of a sentence (you can insert here whatever you like)
If z > 1 Then
Cells(i, 2) = "The Cells from A" & i & " to A" & (i - z) & " are similar."
End If
z = 0
End If
End If
' increment i and the job is done
i = i + 1
Loop
End Sub
This seems kinda clunky and theres probably a better solution, but thats the best I came up with. Have fun.
Related
Sub Highlight_Diff()
Dim i, j As Integer
i = Starting_Row
Do While Cells(i, 3).Value <> ""
For j = 1 To 2 * Currencies
If Abs(Cells(i, 3 * (3 * Currencies + 1) + j).Value) > 100000 Then
Cells(i, 3 * (3 * Currencies + 1) + j).Interior.ColorIndex = 6
End If
Next j
Loop
End Sub
Note Currencies and Starting_Row are just constant integers. As you can see all I am trying to do is loop though rows of code and higlight particularly large balances (for context this has to do with discrepancies which arise due to exchange rate differentials). When I try running this simple sub, my Excel crashes... every single time. I tried running it in a module instead of workbook but that didn't work either. It's definitely not because there are two many rows (only a few hundred, and only 4 cells per row as currencies is set to 2 for this particular job). Any idea on how I can fix this?
*NOTE: Yes I did have i = 1 instead of j = 1 in my for loop at first but I fixed this and it still crashes, so that doesn't appear to be the problem.
You seem to have an error here : i is always reset to 1 at the beginning you the main loop since you also use it in the for.
Do While Cells(i, 3).Value <> ""
For i = 1 To 2 * Currencies
If Abs(Cells(i, 3 * (3 * Currencies + 1) + j).Value) > 100000 Then
Cells(i, 3 * (3 * Currencies + 1) + j).Interior.ColorIndex = 6
End If
Next j
Loop
Since you use next j, I beleive you intended to use that, so change the 'i' in the for for a 'j' and see if it works
If it's the source of your problem, you may be witnessing an infinite loop.
As pointed by cyboashu you might also need to use a Long since vba Integers only count up to 32767 and down to -32768
Your while loop is always looking at the same value.
Since i is no longer a looping variable (in the corrected code) you are left with the following while loop:
Do While Cells(Starting_Row, 3).Value <> ""
...
Loop
You aren't changing the value of Starting_Row, and you aren't changing the value in the cell.
Either you (1) never execute the Do-While code or (2) you execute it forever.
I expect you forgot to increment i
See if this works:
Sub Highlight_Diff()
Dim i, j As Integer ' better practice to make this type a Long
i = Starting_Row
Do While Cells(i, 3).Value <> ""
For j = 1 To 2 * Currencies
If Abs(Cells(i, 3 * (3 * Currencies + 1) + j).Value) > 100000 Then
Cells(i, 3 * (3 * Currencies + 1) + j).Interior.ColorIndex = 6
End If
Next j
i = i + 1 'moves you to the next row until empty cell is found
Loop
End Sub
I have an Excel template that I am working on as a tool for our department, and it has multiple sheets that can be copied, and what it ultimately does, is compile data from the first few sheets to create a list of sheet goods to be produced in our manufacturing facility. Each line item consists of a quantity, and then a core material, and two faces. This list is a separate sheet, that can be copied to create many different lists all referencing data from the same first three sheets.
I need to be able to quickly, and in a somewhat automated process, create a secondary list from the data of the first list. The secondary list needs to tell give me a total of each unique core, face, and backer. Some of the backers are the same as the face, so those should be consolidated.
I have a macro already that can allow the user to select a range of data, and then it spits out a consolidated list with quantities and names. The problem is this only works for 3 columns of data, and uses the 3rd column as the name, and the first as the quantity. I haven't figured out how to get it to look to columns of data that are not exactly adjacent, or more than 3 columns.
I am much more comfortable with spreadsheet formulas, but I'm thinking a macro would be the best solution if I can figure it out, as the end users of this spreadsheet have limited knowledge of excel, and I don't want to rely on them memorizing a bunch of steps.
First List
Start of Second List
Here is the macro I have so far.
Sub Macro1()
Dim i, J, K, L, M, R1, R1F, C1F, Temp As Integer
Dim SemiFinalData(500, 2) As Variant
Dim FinalData(500, 2) As Variant
i = J = 0
Set InputData = Application.InputBox(prompt:="Select the full range of Data (Qty Through Description)", Type:=8)
R1 = InputData.Rows.Count 'Gets Data to Summarize and Counts the Number of Rows
For i = 1 To R1
If InputData(i, 3) <> "" Then
SemiFinalData(J, 0) = InputData(i, 1)
SemiFinalData(J, 1) = InputData(i, 2)
SemiFinalData(J, 2) = InputData(i, 3)
J = J + 1
End If
Next i 'Extracts Non-Blank Data into Array
M = 0
For i = 0 To J - 1 'Loops for each value in SemifinalData
L = 0
For K = 0 To J - 1 'Second loop for each value in SemifinalData
If SemiFinalData(i, 2) = FinalData(K, 2) Then 'Counter for Duplication Test
L = L + 1
End If
Next K
If L < 1 Then 'Tests for Duplication and Extracts Data to FinalData Array
FinalData(M, 1) = SemiFinalData(i, 1)
FinalData(M, 2) = SemiFinalData(i, 2)
M = M + 1
End If
Next i
For i = 0 To M - 1
Temp = 0
For K = 0 To J - 1
If FinalData(i, 2) = SemiFinalData(K, 2) Then
Temp = Temp + SemiFinalData(K, 0)
End If
Next K
FinalData(i, 0) = Temp
Next i
Set OutputData = Application.InputBox(prompt:="Select the first Cell of Output Range (for Qty)", Type:=8)
R1F = OutputData.Row
C1F = OutputData.Column 'Gets Row/Column for Start of Output Range
For K = 0 To 2
Cells(R1F, C1F + K).Select
For i = 0 To M - 1
Selection = FinalData(i, K)
ActiveCell.Offset(1, 0).Range("A1").Select 'Writes Data to Sheet
Next i
Next K
End Sub
Essentially I am struggling with the 3 types of data on the same row from the first list, and the best way to separate them onto their own line on the second sheet.
You may want to look at using
Worksheets().range().AdvancedFilter(....)
This could help you pick out the data that you are looking for much easier. Check the office vba reference for more details.
I want to copy the cells "A2:A" & patientprofiles + 1 and paste them in the first unused row in column D (i.e., there should be no blank cells between what's already in column D and what I want to paste there, but I also don't want to paste over what's already there). I then want to repeat this process a user-defined number of times (this variable will be called g1_observations). I then want to copy the cells "A" & patientprofiles + 2 & ":A" & 2 * patientprofiles + 1 to the new last used row in column D (i.e., taking into account that I've just pasted patientprofiles number of cells g1_observations number of times at the bottom of column D. I want to continue repeating this process a user-defined number of times (this number of times is defined by the variable numberofgrids).
For example: imagine that the user has defined that there will be three grids. Grid 1 will have 2 observations, Grid 2 will have 3 observations, and Grid 3 will have 4 observations. Also imagine that patientprofiles has been set to 40.
If this is the case, there will already be values in cells D1:D121, so I want to begin pasting in D122. I want to paste the cells A2:A41 (40 cells because patientprofiles = 40) to cells D122:D161; I want to paste the cells A42:A81 to cells D162:D201 and again to D:202:D241; and I want to paste cells A82:A121 to cells D242:D281, again to cells D282:D321, and again to cells D322:D361. I'm pasting each "grid" one less time than the number of observations for that grid, because the first group of observations for all grids is what's contained in cells D2:D121. End example
I'm pretty sure I need to use a nested For...Next loop in order to do this, but I'm having trouble with both the inner and outer loop. I think the outer loop should go something like this:
Dim i as long
For i = 0 to numberofgrids - 1
[insert inner loop here]
Next
As far as the inner loop goes, I'm not really sure what I'm doing because it keeps pasting over itself when I am pasting from two grids. The current code I have uses repeated For...Next loops and doesn't work:
Dim myLastRow as Integer
myLastRow = Worksheets("Work").UsedRange.Rows.Count
Dim j as Long
For j = 1 To g1_observations - 1
If j = 1 Then
Range(Cells(2, 1), Cells((patientprofiles + 1), 1)).Copy _
Destination:=Worksheets("Work").Cells(j * myLastRow + 1, 4)
ElseIf j > 1 Then
Range(Cells(2, 1), Cells((patientprofiles + 1), 1)).Copy _
Destination:=Worksheets("Work").Cells((j + 1) * (myLastRow / 2) + 1, 4)
Else: Range("A1").Select
End If
Next
For j = 1 To g2_observations - 1
If j = 1 Then
Range(Cells(patientprofiles + 2, 1), Cells((2 * patientprofiles + 1), 1)).Copy _
Destination:=Worksheets("Work").Cells(j * myLastRow + 1, 4)
ElseIf b > 1 Then
Range(Cells(patientprofiles + 2, 1), Cells((2 * patientprofiles + 1), 1)).Copy _
Destination:=Worksheets("Work").Cells((b + 1) * (myLastRow / 2) + 1, 4)
Else: Range("A1").Select
End If
Next
It pastes over itself, and sometimes it skips lines. I can't really figure out how to reconcile myLastRow with a loop.
I think the inner loop should probably start off something like this:
Dim j as Long
For j = 0 to gj_observations - 1
Range(Cells(j * XXX + 2, 1), Cells((j + 1) * patientprofiles + 1).Copy _
Destination:=Worksheets("Work").Cells(myLastRow * j + 1) , 4
but I'm having difficulty because the variables are called g1_observations, g2_observations, g3_observations, etc., all the way up to g10_observations, and obviously gj_observations won't work. I want to loop on the number between "g" and "_", but I don't know how to get VBA to read variables that way, or if that's possible at all.
Can anyone help me out here? My mind is spinning from trying to understand the concept of loops, especially with different variables at each level.
Also, side question, how do you tell VBA to do nothing in an If statement? I currently have it selecting A1 by writing Else: Range("A1").Select, but I'm sure there's a better way of doing it.
When you're writing macros, it's a better practice to work with ranges and avoid manipulating cells one at a time in a loop. Your macro will run much faster and the code will be clearer.
If you want to create a set of variables that you can access by number, you would use something called an array. This is a pretty fundamental concept that exists in almost every programming language, so I'll refer you to MSDN or your favorite VBA language reference guide for more details.
Dim ws As Worksheet
Dim lr As Long ' Last Row
Dim szpp As Long ' Size (rows) patient profiles
Dim szgobsrv(2) As Long ' Size (rows) observation groups
Dim i As Long
Dim j As Long
Dim SourceCells As Range
Dim TargetCell As Range
Set ws = Sheets("Work")
szpp = 40
szgobsrv(0) = 1
szgobsrv(1) = 2
szgobsrv(2) = 3
For i = 0 To UBound(szgobsrv)
lr = ws.UsedRange.Row + ws.UsedRange.Rows.Count - 1
' copy the patient profile cells multiple times depending on group size
For j = 0 To szgobsrv(i) - 1
Set SourceCells = ws.[A2].Offset(i * szpp).Resize(szpp)
Set TargetCell = ws.[D1].Offset(lr + j * szpp)
SourceCells.Copy TargetCell
Next
Next
Note the usage of the Resize and Offset methods. These are helpful Range methods that can change the size and position of a range by a fixed amount.
The main problem you are having with values being over written is that youre not using Offset.
Another important thing to remember about nested loops is that the nested loop runs i times per loop of the upper level loop. I am thinking that nested loops here might not be good for you. You could probably just make them all independent loops?
If you want to loop to the number contained within the variable you might want to set that variable equal to a number.
example:
g2_observations =2
For j = 1 To g2_observations - 1
Aside from this I am actuall yhaving difficulty understanding what you need, but hopefully this helps?
numberofgrids = input
i = 1 to numberofgrids
gridCount = gridCount + 1
'Loop Stuff
Case Select gridCount
Case is = 1
'logic
Case is = 2
'logic
Etc etc
End Select
If numberofgrids = gridCount Then
Exit For
End If
Next i
Code
n = Worksheets("Datasheet").UsedRange.Rows.count
For l = 2 To k
check = Application.Find(Worksheets("AFAS Dump").Cells(l, 1), Worksheets("Datasheet").Range("K4:K10000000"))
If check = 0 Then
Cells(n + 1, 1) = Worksheets("AFAS Dump").Cells(l, 13)
End If
Next l
AFAS Dump column 1 contains an amount of nr's. Datasheet also contains an amount of nr's. I want to check whether a nr from AFAS dump is also in Datasheet. If not I want to add that nr to datasheet. I want to use Match or Find but they both give me problems.
Another thing is my K10000000, I want the nr to be changed by a parameter but ive noticed that doesn't work. I prefer Ke where e will be assigned to a value.
It's a little unclear what you are trying to achieve as you've got a reference to Column 13 in one of the lines which doesn't make sense if you are trying to add to Column K. If you want the macro to check if a number from Column 1 in the 'AFAS Dump' sheet is in Column K of the 'Datasheet' and add it to the bottom of 'Datasheet' if it's not already there then try this:
n = Worksheets("Datasheet").Cells(Rows.Count,11).End(xlup).Row
e = Worksheets("AFAS Dump").Cells(Rows.Count,1).End(xlup).Row
For l = 2 To e
If Worksheetfunction.Match(Worksheets("AFAS Dump").Cells(l, 1), _
Worksheets("Datasheet").Range("K4:K" & n),0) = 0 Then
Worksheets("Datasheet").Cells(n + 1, 11) = Worksheets("AFAS Dump").Cells(l, 1)
n = n + 1
End If
Next l
I am trying to write a macro to find if a cell has 5 numeric values and if it does, I need to add a 0 at the end.
My macro already has some steps in it.
For example
Cell BZ2 = 9.48E+00
My macro finds the decimal point and replaces it with 94811E-5
I need to add a Zero in this case, because there are 5 numeric values, AND only when the last three characters are E-5.
Expected result is 948110E-5.
I am using a number stored as text.
Can anyone help me out?
Sub TextFormat()
Dim c As Range
Dim d As Range
For Each c In Sheets("order_export").Range("F2:F10000").Cells
If StrComp(Right(c.Value, 1), "R", vbTextCompare) = 0 Then
c.Offset(0, -1).Value = c.Offset(0, -1).Value & "R"
c.Value = Left(c.Value, Len(c.Value) - 1)
End If
Next c
For Each d In Sheets("order_export").Range("BZ2:BZ10000").Cells
If InStr(1, d.Value, ".", vbTextCompare) > 0 Then
d.NumberFormat = "#"
d.Value = Replace(d.Value, ".", "")
d.Value = d.Value & "E-5"
End If
Next d
End Sub
using this conditional
if isNumeric(left(text,5)) AND right(text,3) = "E-5" then
'add zero
text = left(text,5) & "0" & right(text, len(text) - 5)
end if
will add the 0 after the first 5 if the first 5 characters are numeric and the last 3 are e-5. the left function takes the first 5 characters. the isNumeric checks if they are numeric. and then the rest, takes the first 5 characters, puts a 0, and then the right takes all characters starting from the right going up till length - 5 (we already have the first 5 characters)
edit
as pointed out, if there is already a 0, like 123450E-5 then an extra would be added.
add ANd len(text) = 8 so that it only adds the 0 if there are 8 characters.
Excel doesn't short circuit so for coding efficiency it is better to break an AND into IF's with the most likely errors first, then the breaches
Also never using the variant functions Left and Right use string functions Left$ and Right$ instead
This link is an excellent resource re coding optimisation.
Re-cutting the earlier answers would be something like this:
c = "94811E-5"
If Len(c) = 8 Then
If IsNumeric(Left$(c, 5)) Then
If Right$(c, 3) = "E-5" Then c = Left$(c, Len(c) - 3) & "0" & Right$(c, 3)
End If
End If
MsgBox c