I have one column with the names (First Name, Last Name) but sometimes there are the certificates, grades etc added to the names (ex: "John Smiths MBA"; "Susan Smiths FCA, ACCA"). The number of variable is countless but I identified the most common (there are many). Please help how to build the macro to clean this?
I've been using one by one, with:
Selection.Replace What:=" FCA,", Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=True, _
ReplaceFormat:=False
But I guess there must be more efficient way to build this macro (and edit in case when new "unwanted extension is spotted).
Try this code
Sub Test()
Dim e, a, i As Long
Application.ScreenUpdating = False
For Each e In Array("MBA", "FCA", "ACCA", ", ")
Columns(1).Replace e, "", 2
Next e
With Range("A1", Cells(Rows.Count, "A").End(xlUp))
.Value = Evaluate(Replace("IF(COLUMN(#)=1,TRIM(#),TRIM(PROPER(#)))", "#", .Address))
End With
Application.ScreenUpdating = True
End Sub
I assume all the certificates and grades are 3 to 4 letters at the end of names, and it's all in UPPER case. Try the code based on this scenario.
Sub Test()
Dim name As String
i = 2
name = Range("A" & i).Value
While name <> ""
If Right(name, 4) = UCase(Right(name, 4)) Then
Range("A" & i).Value = Left(name, Len(name) - 4)
ElseIf Right(name, 3) = UCase(Right(name, 3)) Then
Range("A" & i).Value = Left(name, Len(name) - 3)
End If
i = i + 1
name = Range("A" & i).Value
Wend
End Sub
Related
What I want the Macro to accomplish:
I want the user to be able to fill in data from E2 to E9 on the spreadsheet. When the user presses the "Add Car" button the macro is supposed to be executed. The makro then should take the handwritten data, copy everything from E2:E9 and put it into a table that starts at with C13 and spans over 7 columns, always putting the new set of data in the next free row. It is also supposed to check for duplicates and give an alert while not overwriting the original set of data
So my problem is, that I want the Macro I'm writing to take the information put into certain cells and then copy them into a table underneath.
I'm starting the Macro like this
Sub addData()
Dim lastrow As Long, nextBlankRow As Long
lastrow = Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlPrevious, _
MatchCase:=False).Row
nextBlankRow = lastrow + 1
Here I try to define how the Macro is supposed to find the last empty cell and also define lastrow and nextBlankRow.
After that I'm starting with a simple If statement to see if the person has at least something in E2 on the same sheet.
If Range("E2") = "" Then
MsgBox "Wählen Sie ein KFZ aus!"
Range("E2").Select
Exit Sub
End If
This works. When I'm not putting something into E2 I get the textbox with the alert.
Anyway if the IF-Statement is not triggered to exit the sub the Macro is given the instructions to get the information and put it in the table below
Cells(nextBlankRow, 3) = Range("E2")
Cells(nextBlankRow, 4) = Range("E3")
Cells(nextBlankRow, 5) = Range("E4")
Cells(nextBlankRow, 6) = Range("E5")
Cells(nextBlankRow, 7) = Range("E6")
Cells(nextBlankRow, 8) = Range("E7")
Cells(nextBlankRow, 9) = Range("E8")
Here seems to be a problem that probably relates to me failing to define variables correctly?
Because the Macro finds the right row but only overwrites into that row. So it ignores the fact that it "should" skip to the nextBlankrow which I defined earlier as
nextBlankRow = lastrow + 1
In addition to that I also have a line of code inplace which is supposed to check for duplicates
Dim p As Long, q As Long
p = 13
q = p + 1
Do While Cells(p, 3) <> ""
Do While Cells(q, 3) <> ""
If Cells(p, 3) = Cells(q, 3) And Cells(p, 4) = Cells(q, 4) Then
MsgBox "Datensatz schon vorhanden!"
Range(Cells(q, 3), Cells(q, 9)).ClearContents
Else
q = q + 1
End If
Loop
p = p + 1
q = p + 1
Loop
End Sub
Which always gives a false return. So even if the same set of Data is copied twice into the same row (as it does) it only "refreshes" the data and doesn't say "you're not allowed to do that".
I'm at a loss here.
Here's the full code for ease of use
Sub addData()
Dim lastrow As Long, nextBlankRow As Long
lastrow = Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlPrevious, _
MatchCase:=False).Row
nextBlankRow = lastrow + 1
If Range("E2") = "" Then
MsgBox "Wählen Sie ein KFZ aus!"
Range("E2").Select
Exit Sub
End If
Cells(nextBlankRow, 3) = Range("E2")
Cells(nextBlankRow, 4) = Range("E3")
Cells(nextBlankRow, 5) = Range("E4")
Cells(nextBlankRow, 6) = Range("E5")
Cells(nextBlankRow, 7) = Range("E6")
Cells(nextBlankRow, 8) = Range("E7")
Cells(nextBlankRow, 9) = Range("E8")
Dim p As Long, q As Long
p = 13
q = p + 1
Do While Cells(p, 3) <> ""
Do While Cells(q, 3) <> ""
If Cells(p, 3) = Cells(q, 3) And Cells(p, 4) = Cells(q, 4) Then
MsgBox "Datensatz schon vorhanden!"
Range(Cells(q, 3), Cells(q, 9)).ClearContents
Else
q = q + 1
End If
Loop
p = p + 1
q = p + 1
Loop
End Sub
```
Please, test the next code:
Sub copyRangeOnLastEmptyRow()
Dim sh As Worksheet, arr, lastERow As Long, matchCel As Range
Set sh = ActiveSheet
arr = sh.Range("E2:E9").value
lastERow = sh.Range("C" & sh.rows.Count).End(xlUp).row + 1
If lastERow < 13 Then lastERow = 13
'check if the range has not been alredy copied:
Set matchCel = sh.Range("C13:C" & lastERow - 1).Find(WHAT:=sh.Range("E2").value, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
If Not matchCel Is Nothing Then
MsgBox sh.Range("E2").value & " has been found in cell " & matchCel.Address & "."
'bring up the data of the existing row:
sh.Range("E3:E9").value = Application.Transpose(sh.Range(matchCel.Offset(0, 1), matchCel.Offset(0, 7)).value)
Exit Sub
End If
sh.Range("C" & lastERow).Resize(1, UBound(arr)).value = Application.Transpose(arr)
sh.Range("E2:E9").ClearContents
End Sub
This is my first time using VBA and macros in excel, or excel really for that matter. I appreciate any help or insight that you could give me, ranging from what functions to loops can help me succeed in this task
I am trying to get this workbook set up from this:
Sample Work Book
I get a list that has to be reordered in order to import into another system. My task list is as follows for a macro:
Names and companies have to be merged into one, if there is a different name of a person, that must be concatenated. There will not be two different companies per company header.
Every File ID per company must be concatenated
Individual fees must be replaced with total fee per company.
Sorted by internal ID #, A-Z
Only one header on the new sheet
To look like this:
Target Work Book
My code below runs this: Current Progress
Sub format()
Application.ScreenUpdating = False
'This is the setup to get rid of unnecessary cells'
Dim rCell As Range
Dim cRow As Long, LastRow As Long
LastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
'''Delete Merged Cells'''
With Worksheets("Sheet1").Range("A1", Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp))
Do
Set c = .Find(What:="*Company Name:*", After:=[A1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not c Is Nothing Then
cRow = c.Row
c.EntireRow.Delete
End If
Loop While Not c Is Nothing And cRow < LastRow
End With
'''Delete Headings'''
With Worksheets("Sheet1").Range("A1", Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp))
Do
Set c = .Find(What:="*File #*", After:=[A1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not c Is Nothing Then
cRow = c.Row
c.EntireRow.Delete
End If
Loop While Not c Is Nothing And cRow < LastRow
End With
''' Delete Sub Total"""
With Worksheets("Sheet1").Range("A1", Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp))
Do
Set c = .Find(What:="*Sub Total:*", After:=[A1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not c Is Nothing Then
cRow = c.Row
c.EntireRow.Delete
End If
Loop While Not c Is Nothing And cRow < LastRow
End With
End Sub
Again, I appreciate any help on this matter. Thank you!
There are a lot of ways to loop through the cells.
I picked column D with the company name as it didn't have too much clutter.
It's usually good to find the last row, to not loop through cells that we don't need. THere is a lot of ways for doing so as well. Today we'll go with Range("D" & .Rows.Count).End(xlUp).Row.
For the loop, we can use the For next approach, example:
For i = 1 To Sheets(1).Range("A" & Sheets(1).Rows.Count).End(xlUp).Row
If Not Cells(i, 4).Value = "" Then
Next i
But this time, I went with the For Each, because I think it's a bit more readable.
Sub groupingEach()
Dim entry As Variant, prev As String, lRow As Long, lRow2 As Long
Dim inSht As Worksheet, outSht As Worksheet
Set inSht = Sheets(1)
Set outSht = Sheets(2)
lRow = inSht.Range("D" & inSht.Rows.Count).End(xlUp).Row 'last row
For Each entry In inSht.Range("D1:D" & lRow) 'loop 1st sheet
lRow2 = outSht.Range("D" & outSht.Rows.Count).End(xlUp).Row 'last row in output
If entry = prev And Not entry = "" Then
'-Group'
If InStr(outSht.Cells(lRow2, 3), entry.Offset(, 1)) = 0 Then 'does name exist?
outSht.Cells(lRow2, 3) = outSht.Cells(lRow2, 3) & vbNewLine & entry.Offset(, 1)
End If
outSht.Cells(lRow2, 5) = outSht.Cells(lRow2, 5) & vbNewLine & entry.Offset(, -2)
outSht.Cells(lRow2, 6) = outSht.Cells(lRow2, 6) + entry.Offset(, 2)
ElseIf Not entry = prev And Not entry = "" And Not entry = "Company" Then
'-New row
prev = entry 'Save company name for comparison
outSht.Cells(lRow2 + 1, 1) = entry.Offset(, -3)
outSht.Cells(lRow2 + 1, 2) = "Payable" 'Where to get this value?
outSht.Cells(lRow2 + 1, 3) = entry.Offset(, 1)
outSht.Cells(lRow2 + 1, 4) = entry
outSht.Cells(lRow2 + 1, 5) = entry.Offset(, -2)
outSht.Cells(lRow2 + 1, 6) = entry.Offset(, 2)
End If
Next entry
outSht.Cells(lRow2 + 3, 1).Value = "Grand Total:"
outSht.Cells(lRow2 + 3, 2).Formula = "=SUM(F:F)"
End Sub
From the examples, this should handle the document all the way from the Sample to the target. I wanted to loop the value copying, but the change in column order made it annoying.
I have a code , it loops through the destinated folder and every single file in the folder.
i have 2 questions
1) how can i modify this code and add it into my main code so that it would work without having compile error for not declaring the variables
For Each cell In Range("B1", Cells(Rows.count, "B").End(xlUp))
With cell
CodeExists = InStr(1, .Value, "testflow")
'Check that "Code:" exists
If CodeExists > 0 Then
.Value = Mid(.Value, CodeExists + 18, 3)
End If
End With
Next
2) if question 1 can't be done,
wks.Cells(BlankRow, 6).Replace What:="hometmastresh", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
wks.Cells(BlankRow, 6).Value = WorksheetFunction.Transpose(Split(wks.Cells(BlankRow, 6), "_"))
i would like to know how i can modify these 2 codes so that i can split my original string: "hometmastresh_enciivedexterXXtresh_tepootsXXXXXXXXXXXXXXtepootFile" that is currently in row E with "X" being unknown numbers and the fact that it will be different in every file.
i would like to split the original string into "XX" into Row F and "XXXXXXXXXXXXXX" into Row G respectively
i am still getting "01tresh_tepoots20191204756890tepootFile"
So after you have got the text using .Find, you can use Split. For example
Dim s As String
s = Split("01tresh_tepoots20191204756890tepootFile", "tepoot")(1)
s = Mid(s, 2, 8) & " " & Right(s, 6)
Debug.Print s
Edit
Your code
If Not aCell Is Nothing Then
aCell.Formula = Replace(aCell.Formula, , "")
s = Split(aCell.Value, "tepoots")(1)
End If
should be as shown below. This will put "20191204 756890" or whatever the number is in the cell.
If Not aCell Is Nothing Then
s = Split(aCell.Value, "tepoots")(1)
s = Mid(s, 2, 8) & " " & Right(s, 6)
aCell.Value = s
End If
Use Left/Right to get the ends of the string and concatenate them with a space
Dim v As String
'...
'...
If CodeExists > 0 Then
v = Mid(.Value, CodeExists + 18, 3)
.Value = Left(v, 8) & " " & Right(v, 6)
End If
the code below works 100%. It scans for a match in Column B and copies and renames a group of cells when a match is found. However the is a line For lRow = Sheets("HR-Calc").Cells(Cells.Rows.count, "b").End(xlUp).Row To 7 Step -1
Where the step -1 will scan row by row from the bottom of the sheet until a match is found. It would be much easier if the step was set to End.(xlUp) instead of -1. searching every row is overkill because of how the data is set up End.(xlUp) would massive cut down the run time.
Is something like this possible?
Sub Fill_CB_Calc()
M_Start:
Application.ScreenUpdating = True
Sheets("summary").Activate
d_input = Application.InputBox("select first cell in data column", "Column Data Check", Default:="", Type:=8).Address(ReferenceStyle:=xlA1, RowAbsolute:=True, ColumnAbsolute:=False)
data_col = Left(d_input, InStr(2, d_input, "$") - 1)
data_row = Right(d_input, Len(d_input) - InStr(2, d_input, "$"))
Application.ScreenUpdating = False
Sheets("summary").Activate
Range(d_input).End(xlDown).Select
data_last = ActiveCell.Row
If IsEmpty(Range(data_col & data_row + 1)) = True Then
data_last = data_row
Else
End If
For j = data_row To data_last
CBtype = Sheets("summary").Range(data_col & j)
Sheets("HR-Calc").Activate
For lRow = Sheets("HR-Calc").Cells(Cells.Rows.count, "b").End(xlUp).Row To 7 Step -1
If Sheets("HR-Calc").Cells(lRow, "b") = CBtype Then
CBend = Sheets("HR-Calc").Range("C" & lRow).End(xlDown).Row + 1
Sheets("HR-Calc").Rows(lRow & ":" & CBend).Copy
CBstart = Sheets("HR-Calc").Range("c50000").End(xlUp).Row + 2
ActiveWindow.ScrollRow = CBstart - 8
Sheets("HR-Calc").Range("A" & CBstart).Insert Shift:=xlDown
CBold = Right(Range("c" & CBstart), Len(Range("C" & CBstart)) - 2)
box_name = Sheets("summary").Range(data_col & j).Offset(0, -10)
CBnew = Right(box_name, Len(box_name) - 2) & "-" ' <--this is custom and can be changed based on CB naming structure
If CBnew = "" Or vbCancel Then
End If
CBend2 = Range("c50000").End(xlUp).Row - 2
Range("C" & CBstart + 1 & ":" & "C" & CBend2).Select
Selection.Replace What:=CBold & "-", Replacement:=CBnew, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("C" & CBstart).FormulaR1C1 = "CB" & Left(CBnew, Len(CBnew) - 1)
GoTo M_Start2
Else
End If
Next lRow
M_Start2:
Next j
YN_result = MsgBox("Fill info for another block/inverter?", vbYesNo + vbExclamation)
If YN_result = vbYes Then GoTo M_Start
If YN_result = vbNo Then GoTo jumpout
jumpout:
' Sheets("summary").Range(d_input).Select
Application.ScreenUpdating = True
End Sub
I'm not sure if this will help but I've had a great performance increase with pulling the entire range you need to loop through into a variant array and then looping through the array. If I need to loop through large data sets, this method has worked out well.
Dim varArray as Variant
varArray = Range(....) 'set varArray to the range you're looping through
For y = 1 to uBound(varArray,1) 'loops through rows of the array
'code for each row here
'to loop through individual columns in that row, throw in another loop
For x = 1 to uBound(varArray, 2) 'loop through columns of array
'code here
Next x
Next y
You can also define the column indexes prior to executing the loop. Then you only need to execute the you need to pull those directly in the loop.
'prior to executing the loop, define the column index of what you need to look at
Dim colRevenue as Integer
colRevenue = 5 'or a find function that searches for a header named "Revenue"
Dim varArray as Variant
varArray = Range(....) 'set varArray to the range you're looping through
For y = 1 to uBound(varArray,1) 'loops through rows of the array
tmpRevenue = CDbl(varArray(y, colRevenue))
Next y
Hope this helps.
Look at doing a .find from the bottom up.
Perform a FIND, within vba, from the bottom of a range up
That will eliminate the need to do the for loop from the last row to the first occurrence of the value you want to locate.
Please help. I can not figure out how to get this to only search columns B and J exclusively. It is searching the range B:B through J:J. Everything else works fine.
Sub Find_Item(SNfound, SNRng, IDFound)
'The user is prompted to input either a serial number or unique ID number into a textbox on a userform.
'This is suppose to search only columns B (serial number) and J (ID number) in Table2 for the number the user entered
'Everything works except it is not limiting the search to only columns B and J. It is searching all columns from B through J.
Dim FindSNID As String
'note -- SNfound and IDFound are Dim As Boolean, SNRng is Dim As Range
Call ResetFilters 'this sub removes all filtering from the active sheet
FindSNID = SNID_textbox.Value
If Trim(FindSNID) <> "" Then
With Sheets("Inventory").Range("B:B", "J:J")
Set SNRng = .Find(What:=FindSNID, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not SNRng Is Nothing Then
SNRng.Activate
'If a match was found in column B (serial number) then display a MsgBox that the item was found and it's self location is xxxxxx from column W (offset 0,21)_
'and it's current status is either available or checked out (offset 0,23)
If SNRng.Column = 2 Then
MsgBox "A matching serial number was found in location " & SNRng.Offset(0, 21).Value & vbCrLf & _
"It's current status is " & SNRng.Offset(0, 23).Value
Areabox2.Value = SNRng.Offset(0, 28).Value
Sectionbox2.Value = SNRng.Offset(0, 29).Value
Shelfbox2.Value = SNRng.Offset(0, 30).Value
SNfound = True
IDFound = False
End If
'If a match is found in column J (ID Number)then the item's shelf location and status is displayed.
If SNRng.Column = 10 Then
MsgBox "A matching ID number was found in location " & SNRng.Offset(0, 13).Value & vbCrLf & _
"It's current status is " & SNRng.Offset(0, 15).Value
Areabox2.Value = SNRng.Offset(0, 28).Value
Sectionbox2.Value = SNRng.Offset(0, 29).Value
Shelfbox2.Value = SNRng.Offset(0, 30).Value
SNfound = False
IDFound = True
End If
End If
End With
End If
End Sub
Try creating the range by setting a range variable = Union(Range("B:B"), Range("J:J"))
I finally figured out how to get the Union method to work.
I changed this:
Set SNRng = .Find(What:=FindSNID, _
To this:
Set SNRng = Union(Range("B:B"), Range("J:J")).Find(What:=FindSNID, _
Now the search only searches columns B and J.