Example value: Becky G Smith
I can already get the first name of everybody in Column A and put the result in Column B with this:
For i = 2 To lastrow
x = InStr(1, Cells(i, "A").Value, " ")
y = InStr(1, Cells(i, "A").Value, "#")
If InStr(1, Cells(i, "A").Value, " ") > 0 Then
Cells(i, "B").Value = Left(Cells(i, "A"), x - 1)
ElseIf InStr(1, Cells(i, "A").Value, "#") > 0 Then
Cells(i, "B").Value = Left(Cells(i, "A"), y - 1)
End If
Next i
The ElseIf InStr(1, Cells(i, "A").Value, "#") > 0 Then statement is there because sometimes I'm dealing with emails, like Becky#gmail.com
The problem is getting "Smith" as her last name. I don't want the middle initial. I've tried this for getting the last name:
For i = 2 To lastrow
w = InStr(1, Cells(i, "A").Value, " ")
x = InStr(w, Cells(i, "A").Value, " ")
y = InStr(1, Cells(i, "A").Value, "#")
Z = Len(Cells(i, "A").Value)
If InStr(1, Cells(i, "A").Value, " ") > 0 Then
Cells(i, "C").Value = Right(Cells(i, "A"), Z - x)
ElseIf InStr(1, Cells(i, "A").Value, "#") > 0 Then
Cells(i, "C").Value = Right(Cells(i, "A"), Z - y)
End If
Next i
But ultimately the w in x = InStr(w, Cells(i, "A").Value, " ") brings up a bug. Apparently VBA considers w to equal 0. So I need a way of extracting the text after the second space.
Try this:
Public Function GetLastName(sName As String) As String
Dim aWords() As String
aWords = Split(sName, " ")
GetLastName = aWords(UBound(aWords))
End Function
You can just use it in your sheet
Related
I am receiving "Error 5" when trying to execute below code. Aim is to extract all characters before comma in a cell and then paste them to another cell based on the if statement. I am sure the last line causes the problem but I am not sure why.
Dim r As Long, commapos As Long, m As Long
m = ActiveSheet.Cells(Rows.count, "A").End(xlUp).Row
For r = 2 To m
If Cells(r, 16).Value <> "0" And Cells(r, 9).Value = "" Then
commapos = InStr(1, Cells(r, 8), ",")
Cells(r, 9).Value = Left(Cells(r, 8), commapos - 1)
End If
Next r
End Sub
On the Left function Syntax
Left(string, length) where length can't be less than 0
Try this:
Dim r As Long, commapos As Long, m As Long
m = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
For r = 2 To m
If Cells(r, 16).Value <> "0" And Cells(r, 9).Value = "" Then
commapos = InStr(1, Cells(r, 8), ",")
If commapos <> 0 Then
Cells(r, 9).Value = Left(Cells(r, 8), commapos - 1)
End If
End If
Next r
I have code which is used for concatenation. The cells are dynamic; whenever a change in cells in a range the concatenation function will automatically execute and gives the value. Currently I asked the concatenation function which has to run for the complete range even though the modification is in a single row. Which is causing a lot of time during the execution.
Is there is any way to define to update only a single row that is modified? I know the technique if the range is single column, for multiple columns I didn't have any idea.
My Code
ColumnLetter3 = Split(Cells(1, c1_column).Address, "$")(1)
ColumnLetter4 = Split(Cells(1, c6_column).Address, "$")(1)
Range3 = ColumnLetter3 & st_workrow2 + 1 & ":" & ColumnLetter4 & last_cell1
Set xrng3 = Range(Range3)
If Not Application.Intersect(xrng3, Range(Target.Address)) _
Is Nothing Then
For i = c_row + 1 To last_cell1
If Cells(i, c1_column) = "" And Cells(i, c2_column) = "" And Cells(i, c3_column) = "" And Cells(i, c4_column) = "" And Cells(i, c5_column) = "" And Cells(i, c6_column) = "" Then
Cells(i, c_column) = ""
Else
Cells(i, c_column) = Cells(i, c1_column) & "-" & Cells(i, c2_column) & "-" & Cells(i, c3_column) & "-" & Cells(i, c4_column) & "-" & Cells(i, c5_column) & "-" & Cells(i, c6_column)
Cells(i, c_column).Replace what:="+", Replacement:=""
Cells(i, c_column).Replace what:="-----", Replacement:="-"
Cells(i, c_column).Replace what:="----", Replacement:="-"
Cells(i, c_column).Replace what:="---", Replacement:="-"
Cells(i, c_column).Replace what:="--", Replacement:="-"
If Right(Cells(i, c_column), 1) = "-" Then
l = Len(Cells(i, c_column))
Cells(i, c_column) = Left(Cells(i, c_column), l - 1)
End If
If Left(Cells(i, c_column), 1) = "-" Then
l = Len(Cells(i, c_column))
Cells(i, c_column) = Right(Cells(i, c_column), l - 1)
End If
End If
Next I
Endif
It's hard to tell exactly what you're doing here (perhaps strip down your question?), however looks like you want to get a list of the rows in your target? In that case you can isolate it using Columns(1). See below...
If Not Application.Intersect(xrng3, Range(Target.Address)) _
Is Nothing Then
Dim aCell As Range
For Each aCell In Target.Columns(1).Cells
i = aCell.Row
If Cells(i, c1_column) = "" And Cells(i, c2_column) = "" And Cells(i, c3_column) = "" And Cells(i, c4_column) = "" And Cells(i, c5_column) = "" And Cells(i, c6_column) = "" Then
'skipped....
End If
Next aCell
End If
Every week in work I have a file of around 15000 customers that I need to break up into two categories based on their names. My current code works but it loops through every row taking almost 3 minutes to run. What would be the best way to improve the speed - I'm assuming there are much more efficient methods than the lengthy if statement I've used?
Option Compare Text
Private Sub CommandButton1_Click()
Dim i As Long
Application.ScreenUpdating = False
For i = 2 To Rows.Count
If Cells(i, 33).Value = "Business" Then
Cells(i, 32).Value = "B"
ElseIf Cells(i, 33).Value = "Personal" Then
Cells(i, 32).Value = "P"
ElseIf Cells(i, 12).Value = "N" Then
Cells(i, 32).Value = "B"
ElseIf Cells(i, 12).Value = "Y" Then
Cells(i, 32).Value = "P"
ElseIf Cells(i, 20).Value = "PREMIER" Then
Cells(i, 32).Value = "P"
ElseIf InStr(1, Cells(i, 4), "LTD") <> 0 Then 'Finds each word in customer name, column D, and enters it as business customer
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "LIMITED") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "MANAGE") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "BUSINESS") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "CONSULT") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "INTERNATIONAL") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "T/A") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "TECH") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "CLUB") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "OIL") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "SERVICE") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "SOLICITOR") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf Cells(i, 4).Value = "UIT" Then
Cells(i, 32).Value = "B"
Else
Cells(i, 32).Value = ""
End If
Next i
Application.ScreenUpdating = True
End Sub
If you want to speed up the process, I'd stop using VBA, but write a formula instead.
Example: for finding if a cell equals "Business" or "N", you can use something like this:
=IF(OR(A1="Business";A2="N");"B";"P")
For finding if a cell contains "Business", you can use something like this:
=IF(FIND("Business";A1);"B";"P")
Combining all of this using the OR() worksheet function, you can get the whole thing. Obviously you'll need to drag your formula over your the entire column within your worksheet.
Try
Private Sub CommandButton1_Click()
Dim i As Long, r As Long
Dim vDB As Variant
Dim Ws As Worksheet
Dim rngDB As Range
Set Ws = ActiveSheet
Set rngDB = Ws.UsedRange
vDB = rngDB
r = UBound(vDB, 1)
For i = 2 To r
If vDB(i, 33) = "Business" Then
vDB(i, 32) = "B"
ElseIf vDB(i, 33) = "Personal" Then
vDB(i, 32) = "P"
ElseIf vDB(i, 12) = "N" Then
vDB(i, 32) = "B"
ElseIf vDB(i, 12) = "Y" Then
vDB(i, 32) = "P"
ElseIf vDB(i, 20) = "PREMIER" Then
vDB(i, 32) = "P"
ElseIf InStr(1, vDB(i, 4), "LTD") <> 0 Then 'Finds each word in customer name, column D, and enters it as business customer
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "LIMITED") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "MANAGE") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "BUSINESS") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "CONSULT") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "INTERNATIONAL") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "T/A") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "TECH") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "CLUB") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "OIL") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "SERVICE") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "SOLICITOR") <> 0 Then
vDB(i, 32) = "B"
ElseIf vDB(i, 4) = "UIT" Then
vDB(i, 32) = "B"
Else
vDB(i, 32) = ""
End If
Next i
rngDB = vDB
End Sub
I have two columns, Column A has a set of a few standard values and column B has all unique values. I'm only just experimenting with more complex ways of compiling data than the beginner level so I'm a bit at a loss.
I need to either have a lookup or create a macro that will list only the values in A (once each) but also display which values in B correspond to those in A
for example
A | B
va1|abc
va1|bcd
Va2|xyz
va3|zab
will show (in a single cell) the following
va1: abc, bcd
va2: xyz
va3: zab
Please help!
Option Explicit
Sub Test()
Dim i As Long, j As Long, k As Long
k = 1
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Application.CountIf(Range("C:C"), Cells(i, 1).Value) = 0 Then
Cells(k, 3).Value = Cells(i, 1).Value
For j = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(j, 1).Value = Cells(k, 3).Value And _
InStr(Cells(k, 4).Value, Cells(j, 2).Value) = 0 Then
If Cells(k, 4).Value = "" Then
Cells(k, 4).Value = Cells(j, 2).Value
Else
Cells(k, 4).Value = Cells(k, 4).Value & ", " & Cells(j, 2).Value
End If
End If
Next j
k = k + 1
End If
Next i
For i = 1 To Cells(Rows.Count, 3).End(xlUp).Row
Cells(i, 3).Value = Cells(i, 3).Value & ": " & Cells(i, 4).Value
Cells(i, 4).ClearContents
Next i
End Sub
Edited for single cell
In case your requirement is to "have the grouped data", and not exactly "have one single string per A", you can do this with a "pivot table" putting A and B in the row labels, like in the following picture:
what would be the best way to merge similar rows (only order number letter different a4;a6;a8 and produced quantity) and sum (produced quantity e4;e6;e8) cells? This is how excel table looks
Clarification:
Here is the output I'm looking for
Rows 4;6;8 are the same except Order column (one letter added on 6 and 8) and Produced Column (different produced quantity). Rows 4,6,8 are merged and produced quantity is summed. Rows 6,8 is hidden or deleted.
Here is an example that could solve your problem:
Sub test()
i = 1
produced = 0
While Cells(i, 1) <> "" Or Cells(i + 1, 1) <> ""
If Cells(i, 1) <> "" Then
produced = Cells(i, 5)
j = 1
'second loop to add up every line with the same order, then suppress the lines
While Cells(j, 1) <> "" Or Cells(j + 1, 1) <> ""
If Left(Cells(j, 1), 7) = Left(Cells(i, 1), 7) And i <> j Then
produced = produced + Cells(j, 5)
Cells(j, 5).EntireRow.Select
Selection.Delete Shift:=xlUp
j = j - 1
End If
j = j + 1
Wend
End If
i = i + 1
Wend
Ok, here is the modified #Bitoubi code which helped me:
Sub RemoveSplitOrders()
i = 1
produced = 0
While Cells(i, 1) <> "" Or Cells(i + 1, 1) <> ""
If Cells(i, 1) <> "" Then
produced = Cells(i, 20)
j = 1
'second loop to add up every line with the same order, then suppress the lines
While Cells(j, 1) <> "" Or Cells(j + 1, 1) <> ""
If Left(Cells(j, 1), 8) = Left(Cells(i, 1), 8) Or Left(Cells(j, 1), 9) = Left(Cells(i, 1), 9) Then
If Cells(j, 2) = Cells(i, 2) And i <> j Then
produced = produced + Cells(j, 20)
Cells(i, 20).Value = produced
Range(Cells(j, 20), Cells(j + 1, 20)).EntireRow.Delete Shift:=xlUp
j = j - 1
End If
End If
j = j + 1
Wend
End If
i = i + 1
Wend
End Sub