I have a spreadsheet, BO2009, that is 300k rows long. Only one column contains a formula The others are all pasted values so only one formula needs to be calculated in the entire workbook. Here is the formula: =IFERROR(INDEX('RE2009'!H:H,MATCH('BO2009'!A2,'RE2009'!A:A,0)),1) This formula is copied down to the bottom of the sheet, so 300k times.
RE2009 sheet has 180k rows. 'RE2009'!H:H contains decimal numbers and 'RE2009'!A:A, 'BO2009'!A:A contain ID codes--an 8 character combination of numbers and letters. Both 'RE2009'!A:A, 'BO2009'!A:A are formatted as general.
I use INDEX/MATCH all the time and while most of my spreadsheets are not 300k long, 60k-100k is typical. Right now it takes a couple minutes of my CPU devoting 99% to Excel in order to finish the calculation.
Is that normal? Is there any way to improve Excel's performance?
On top of that I am getting inaccurate results: instead of 0.3 the lookup produces an error.
As suggested, I have filtered the BO2009 sheet down to 80k rows, but still have the same issues. I decided to look at a single formula in particular: =IFERROR(INDEX('RE2009'!H:H,MATCH('BO2009'!A108661,'RE2009'!A:A,0)),1) to see if it worked correctly. The ID that it is looking for with the MATCH function is the 3rd entry in the lookup array, but it still isn't able to produce the correct value (0.3)
It seems that you've found a satisfactory solution to your problem(s) but as a matter of curiosity, you may wish to time this against your current formula based solution to see if there is a measurable increase in speed.
Sub index_match_mem()
Dim v As Long, vVALs As Variant, vTMP As Variant
Dim dRE2009 As Object
Debug.Print Timer
Application.ScreenUpdating = False
With Worksheets("RE2009")
With .Cells(1, 1).CurrentRegion
With .Resize(.Rows.Count, 8)
vTMP = .Cells.Value2
End With
End With
End With
Set dRE2009 = CreateObject("Scripting.Dictionary")
dRE2009.CompareMode = vbTextCompare
For v = LBound(vTMP, 1) To UBound(vTMP, 1)
If Not dRE2009.exists(vTMP(v, 1)) Then _
dRE2009.Add Key:=vTMP(v, 1), Item:=vTMP(v, 8)
Next v
With Worksheets("BO2009")
With .Cells(1, 1).CurrentRegion
With .Resize(.Rows.Count - 1, 2).Offset(1, 0)
vVALs = .Cells.Value2
For v = UBound(vVALs, 1) To LBound(vVALs, 1) Step -1
If dRE2009.exists(vVALs(v, 1)) Then
vVALs(v, 2) = dRE2009.Item(vVALs(v, 1))
Else
vVALs(v, 2) = 1
End If
Next v
.Cells = vVALs
End With
End With
End With
dRE2009.RemoveAll: Set dRE2009 = Nothing
Application.ScreenUpdating = True
Debug.Print Timer
End Sub
This will produce static values in column B of the BO2009 worksheet. The elapsed start and stop in seconds will be in the VBE's Immediate window (Ctrl+G)
Related
I have implemented this method to multiply every array element by a number held in a variable. It is terribly slow.
Is there an accepted "fastest" way to multiply every element in a range by a constant? Or at least one which is not as slow? I have to do this 10 times and it takes a couple of minutes.
MultFactor = 10
For Each cell In Sheet1.Range("B3:B902")
cell.Value = cell.Value * MultFactor
Next cell
The solution cited in Multiply Entire Range By Value? multiplies by a constant (not a variable). If I use this code (changing the range from "A1:B10" to "B3:B902"), I get a nonsense answer.
Dim rngData As Range
Set rngData = Sheet12.Range("B3:B902")
rngData = Evaluate(rngData.Address & "*2")
My original values in B3:B902 are zero for the first 100 elements or so and then increase a bit and finally decrease and have another run of zeros, but what ends up in my range is a series of numbers that clobbers everything in my range. It begins at -224.5 and decreases by 0.5 all the way to the last cell.
-224.5
-224.0
-223.5
etc.
Even if that worked, how would I modify it to use the variable MultFactor?
This will be hundreds to thousands of times faster. The difference is that all of the calcs are done to a VBA array instead of directly to worksheet cells, one by one. Once the array is updated it is written back to the worksheet in one go. This reduces worksheet interaction to just two instances, reading the array and writing it. Reducing the number of instances that your VBA code touches anything on the worksheet side is critical to execution speed.
Sub Mozdzen()
Const FACTOR = 10
Const SOURCE = "B3:B902"
Dim i&, v
v = Sheet1.Range(SOURCE)
For i = 1 To UBound(v)
v(i, 1) = v(i, 1) * FACTOR
Next
Sheet1.Range(SOURCE) = v
End Sub
Building on the above idea, a better way to manage the code is to encapsulate the array multiplication with a dedicated function:
Sub Mozdzen()
Const FACTOR = 10
Const SOURCE = "B3:B902"
With Sheet2.Range(SOURCE)
.Value2 = ArrayMultiply(.Value2, FACTOR)
End With
End Sub
Function ArrayMultiply(a, multfactor#)
Dim i&
For i = 1 To UBound(a)
a(i, 1) = a(i, 1) * multfactor
Next
ArrayMultiply = a
End Function
You need:
rngData = Sheet12.Evaluate(rngData.Address & "*2")
since the address property doesn't include the sheet name by default (so your formula is evaluated in the context of the active sheet's range B3:B902)
Then it would need:
rngData = Sheet12.Evaluate(rngData.Address & "*" & MultFactor)
to add in your variable.
I've been searching for a way to concatenate my Excel (or any other tool/software handling tables) rows based on common cells. As an example:
I have this tab-stop divided table. Each of the values is in a separate row:
angeb* 12 16 18
zyste* 60 61
zynisch* 12
zyste* 60
abstreit* 70
anflunker* 70
angeb* 70
I want to concatenate the rows in a way that the result would be:
angeb* 12 16 18 70
zyste* 60 61
zynisch* 12
abstreit* 70
anflunker* 70
It does work by doing as proposed in this tutorial, but it only concatenates single cell values into another single cell. I also tried going the path basically proposed by this so question and finally leading me to VLOOKUP (description). But they all concatenate in cells.
Basically pretty simple, I need to merge cells with the same Column 1, but keep the columns, just concatenate beyond. The second row can then be deleted, once it is added to the first one. I tried adapting the above scripts, but I could not make it work in one step, just with then converting comma separated values into cells and copying them to new columns. I am not an expert with VBA, but this seems like a very simple functionality, I might as well be missing something. Any help is greatly appreciated.
I have written and color-coded each part of what I did, but here is the general method:
Sort all data A-Z
Use a CountIf statement to count how many times a particular data row shows up.
Assuming 3 columns of data, find MAX() of MaxRows, multiply (here, 3 columns x 2 Rows maximum observed = 6 data max).
Copy the labels, remove duplicates [Green] so you have a condensed table.
Use IndexMatch equations, coupled with IF and IFERROR statements to re-sort the data. Note the +1 for Columns P-Q)
Problem - you can still get a gap, but it's all in the same rows now!
Here's a quick Youtube video on how I did it.
TSpinde Answer 1
I was a little confused by your question so I only concatenated names that were exactly the same.
So the way my code works is it makes an array of tags and when it runs into one that it already has it looks for the next empty slot in the original row. It then adds the value in and does this until it hits an empty cell in the new row. There's a bit of funny business with decreasing the lastrow value and changing the row it's on, but its necessary for it to move to the correct row of data in the next cycle.
This macro assumes that all possible data entries are side by side, for example there wont be a value in C2 and E2 if D2 is empty.
Sub macro()
Dim LastRow As Long
Dim LastCol As Long
Dim TagArray() As String
Dim count As Long
Dim i As Long
Dim j As Long
Dim PreExisting As Boolean
Dim Targetrow As Long
ReDim TagArray(1 To 1)
LastRow = Worksheets(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastCol = Worksheets(1).Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
TagArray(1) = Worksheets(1).Range("A1").Value
For i = 2 To LastRow
PreExisting = False
For j = 1 To UBound(TagArray)
If Worksheets(1).Cells(i, 1) = TagArray(j) Then
PreExisting = True
Targetrow = j
Exit For
End If
Next j
If PreExisting Then
For j = 2 To LastCol
If Not IsEmpty(Worksheets(1).Cells(i, j)) Then
For count = 1 To LastCol
If IsEmpty(Worksheets(1).Cells(Targetrow, count)) Then
Worksheets(1).Cells(Targetrow, count) = Worksheets(1).Cells(i, j)
Exit For
Else
If count = LastCol Then
LastCol = LastCol + 1
Worksheets(1).Cells(Targetrow, LastCol) = Worksheets(1).Cells(i, j).Value
End If
End If
Next count
Else
Exit For
End If
Next j
Worksheets(1).Rows(i).Delete
LastRow = LastRow - 1
i = i - 1
Else
ReDim Preserve TagArray(1 To UBound(TagArray) + 1)
TagArray(UBound(TagArray)) = Worksheets(1).Cells(i, 1)
End If
Next i
End Sub
Hopefully, you find this useful if you wanted to use it in VBA instead of worksheet functions.
I have to average sets of 3 columns.
EXAMPLE:
Blood_Patient1_0_R1, Blood_Patient1_0_R2, Blood_Patient1_0_R3
There average is in a new column Blood_Patient1_0
Similarly, Blood_Patient1_3_5_R1, Blood_Patient1_3_5_R2, Blood_Patient1_3_5_R3
The average is in a new column Blood_Patient1_3_5
This process is being repeated for 8 such sets of columns.
Currently I am averaging using the formula: IF(ISERROR(AVERAGE(B7:D7)),"",AVERAGE(B7:D7)) and auto-filling 21,000 plus rows.
Since there is a pattern in column headings, I was thinking to automate the whole process.
This is what I have thought so far in terms of algorithm:
0, 3_5, 6_25 are time values in column headers.
at each time instant, there are 3 replicates R1, R2,R3 as part of column headers
for time array [3.5h, 6.25h, 9.5h, 11.5h, 16.5h, 25h, 49h, and 156h
]
create a new column
for rows from 2 to 21458
average over replicates from R1 to R3 using above formula
I do not know how to write this in excel. Any help would be appreciated.
Give this a go.
This solution assumes that you have a continuous data set, that is, no gaps between the columns you wish to search through.
Firstly, you will need to include this function. Paste it into the same module as the subroutine. The purpose of this function is to allow the string in each heading to be compared against an array of substrings, as opposed to the single substring permitted by the InStr function.
Function Time_Search(strCheck As String, ParamArray anyOf()) As Boolean
Dim item As Long
For item = 0 To UBound(anyOf)
If InStr(1, strCheck, anyOf(item)) <> 0 Then
Time_Search = True
Exit Function
End If
Next
End Function
Next, paste in this subroutine. I have assummed that the dataset begins at cell A1. Also, I have allowed for a dynamic range, should the number of columns or rows ever change.
Sub Insert_Average_Columns()
Dim HeaderRange As Range
Dim LastRow As Long
Dim c As Range
Set HeaderRange = Range(Range("A1"), Range("A1").End(xlToRight))
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For Each c In HeaderRange.Cells
If Right(c.Value, 2) = "R3" Then
If Time_Search(c.Value, "3_5", "6_25", "9_5", "11_5", "16_5", "25", "49", "156") Then
c.Offset(0, 1).EntireColumn.Insert
c.Offset(0, 1) = "Average of " & Left(c.Value, Len(c.Value) - 3)
c.Offset(1, 1).FormulaR1C1 = "=IFERROR(AVERAGE(RC[-3]:RC[-1]),"""")"
c.Offset(1, 1).AutoFill Range(c.Offset(1, 1).Address, Cells(LastRow, c.Offset(1, 1).Column))
End If
End If
Next c
End Sub
There is one issue with your data. If you want the procedure to insert an average column for T = 25, then it will do so for all columns where T contains the string "25". If there are T= 8.25, 10.25, 15.25, etc, these will all have averages applied. The only way around it would be to include more of the heading string in the parameter array, but I presume you will be dealing with a variable Blood_Patient ID so that probably isn't an option.
My spreadsheet has about 800,000 rows with 30 columns. Customers are interested in duplicate values only in one column. They need the entire row back. For e.g.
MemberId|Name|Address|CircleScore
H111|John Doe|123 W Main|2.4
H222|Jane Doe|124 W Main|3.2
H333|Bob Doe|125 W Main|2.5
H444|Jake Doe|126 W Main|2.1
H555|Mike Doe|127 W Main|2.4
They want the entire rows where there are duplicates in CircleScore. So my filtered excel should only contain:
MemberId|Name|Address|CircleScore
H111|John Doe|123 W Main|2.4
H555|Mike Doe|127 W Main|2.4
I tried highlighting duplicate CircleScore and filtering, but the filtering part takes for ever. I have waited for 15 minutes but still no luck. The duplicates could be around 150k.
Is there an alternative?
I would create an Is_Duplicated indicator column and use that to filter the duplicated CircleScores:
UPDATE (per comments):
Alternatively, you can sort the CircleScore column and make the formula a bit less taxing on your system (NOTE CircleScore must be sorted beforehand):
Please disregard this submission if you are a) getting paid by the hour and feel underpaid, b) planning on a nap while the routine processes, or c) both a) and b).
With any data set approaching 800K rows (with 30 columns) you are going to want to step into the variant array arena. With processing typically 5-7% of the time it takes to work with the worksheet values, it is very appropriate for large data blocks.
Anytime that the word 'duplicates' comes into play, I immediately start thinking about how a Scripting.Dictionary object's unique index on its Keys can benefit. In this solution I used a pair of dictionaries to identify the rows of data with a repeated Circle Score value.
Twenty-four million cells of data is a lot to store and transfer. Bulk methods beat individual methods every time and the bulkiest method of peeling off the data would be to stuff all 800K rows × 30 columns into a variant array. All processing becomes in-memory and the results are returned to a report worksheet en masse.
isolateDuplicateCircleScores code
Sub isolateDuplicateCircleScores()
Dim d As Long, v As Long, csc As Long, stmp As String
Dim ky As Variant, itm As Variant, vVALs As Variant, dCSs As Object, dDUPs As Object
Dim w As Long, vWSs As Variant
'early binding
'dim dCSs As new scripting.dictionary, dDUPs As new scripting.dictionary
appTGGL bTGGL:=False
'late binding - not necessary with Early Binding (see footnote ¹)
Set dCSs = CreateObject("Scripting.Dictionary")
Set dDUPs = CreateObject("Scripting.Dictionary")
'set to the defaults (not necessary)
dCSs.comparemode = vbBinaryCompare
dDUPs.comparemode = vbBinaryCompare
'for testing on multiple row number scenarios
'vWSs = Array("CircleScores_8K", "CircleScores_80K", "CircleScores_800K")
'for runtime
vWSs = Array("CircleScores") '<~~ your source worksheet here
For w = LBound(vWSs) To UBound(vWSs)
'ThisWorkbook.Save
Debug.Print vWSs(w)
Debug.Print Timer
With Worksheets(vWSs(w))
On Error Resume Next
Worksheets(vWSs(w) & "_dupes").Delete
On Error GoTo 0
ReDim vVALs(0)
dCSs.RemoveAll
dDUPs.RemoveAll
'prep a new worksheet to receive the duplicates
.Cells(1, 1).CurrentRegion.Resize(2).Copy
With Worksheets.Add(after:=Worksheets(.Index))
.Name = vWSs(w) & "_dupes"
With .Cells(1, 1)
.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone
.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone
.Value = .Value2
.Offset(1, 0).EntireRow.ClearContents
End With
End With
'finish prep with freeze row 1 and zoom to 80%
With Application.Windows(1)
.SplitColumn = 0
.SplitRow = 1
.FreezePanes = True
.Zoom = 80
End With
'grab all of the data into a variant array
ReDim vVALs(0)
csc = Application.Match("CircleScore", .Rows(1), 0) 'CircleScore column number needed later
vVALs = .Range(.Cells(2, 1), _
.Cells(.Cells(Rows.Count, csc).End(xlUp).Row, _
.Cells(1, Columns.Count).End(xlToLeft).Column)).Value2
'Debug.Print LBound(vVALs, 1) & ":" & UBound(vVALs, 1) '1:~800K
'Debug.Print LBound(vVALs, 2) & ":" & UBound(vVALs, 2) '1:~30
End With 'done with the original worksheet
'populate the dDUPs dictionary using the key index in dCSs
For v = LBound(vVALs, 1) To UBound(vVALs, 1)
If dCSs.exists(vVALs(v, csc)) Then
stmp = vVALs(v, 1)
For d = LBound(vVALs, 2) + 1 To UBound(vVALs, 2)
stmp = Join(Array(stmp, vVALs(v, d)), ChrW(8203))
Next d
dDUPs.Add Key:=v, Item:=stmp
If Not dDUPs.exists(dCSs.Item(vVALs(v, csc))) Then
stmp = vVALs(dCSs.Item(vVALs(v, csc)), 1)
For d = LBound(vVALs, 2) + 1 To UBound(vVALs, 2)
stmp = Join(Array(stmp, vVALs(dCSs.Item(vVALs(v, csc)), d)), ChrW(8203))
Next d
dDUPs.Add Key:=dCSs.Item(vVALs(v, csc)), Item:=stmp
End If
Else
dCSs.Item(vVALs(v, csc)) = v
End If
Next v
'split the dDUPs dictionary items back into a variant array
d = 1
ReDim vVALs(1 To dDUPs.Count, 1 To UBound(vVALs, 2))
For Each ky In dDUPs.keys
itm = Split(dDUPs.Item(ky), ChrW(8203))
For v = LBound(itm) To UBound(itm)
vVALs(d, v + 1) = itm(v)
Next v
d = d + 1
Next ky
'put the values into the duplicates worksheet
With Worksheets(vWSs(w) & "_dupes")
.Cells(2, 1).Resize(UBound(vVALs, 1), UBound(vVALs, 2)) = vVALs
With .Cells(1, 1).CurrentRegion
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
.Rows(1).Copy
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
End With
.Cells.Sort Key1:=.Columns(csc), Order1:=xlAscending, _
Key2:=.Columns(1), Order2:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlYes
End With
End With
Debug.Print Timer
Next w
dCSs.RemoveAll: Set dCSs = Nothing
dDUPs.RemoveAll: Set dDUPs = Nothing
appTGGL
End Sub
Public Sub appTGGL(Optional bTGGL As Boolean = True)
With Application
.ScreenUpdating = bTGGL
.EnableEvents = bTGGL
.DisplayAlerts = bTGGL
.AutoRecover.Enabled = bTGGL 'no interruptions with an auto-save
.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
.CutCopyMode = False
.StatusBar = vbNullString
End With
Debug.Print Timer
End Sub
Sample Data and Results
800K rows × 30 columns of random sample data
~123K rows × 30 columns of duplicate rows (sorted and formatted in about a minute-and-a-half)
Timed Results
tbh, I never got the 32-bit version of Excel on the older laptop to run the 800K pass run more than once without restarting Excel. Once restarted the results were consistent with what is shown. The 64-bit Excel ran repeatedly without a hiccup.
Large Worksheet Addendum
When dealing with worksheets containing large data blocks there are a few general improvements that can limit your wait times. You're using Excel as a medium sized database tool so treat the data worksheet as the raw data that it should be.
If you are not working with a 64-bit version of Excel then you are wasting time with everything you do. See What version of Office am I using? and Choose the 32-bit or 64-bit version of Office.
Save as an Excel Binary Workbook (e.g. .XLSB). The file size is typically 25-35% of the original. Load times are improved and some calculation is quicker (sorry, do not have empirical timed data on the latter). Some operations that crash an .XLSX or .XLSM work fine with an .XLSB.
Disable Auto-Save/Auto-Recover in the options for the workbook. ([alt]+F, T, S, [alt]+D, [OK]). There are few things more irritating than waiting for an auto-save to complete when you are trying to do something. Get used to Ctrl+S when YOU want to save.
Avoid volatile functions¹ at all costs; particularly in formulas that are used in the full scope of the data. A single TODAY() in a COUNTIF formula filled down for the extent of the rows will have you sitting on your thumb more often than not.
Speaking of formulas, revert all formulas to their result values whenever possible.
Merged cells, conditional formatting, data validation and making cells look pretty with formatting and styles slows you down. Minimize the use of anything that takes away from raw data. It isn't like anyone is actually going to look through 800K rows of data.
After removing data use Home ► Editing ► Clear ► Clear All on the vacant cells. Tapping the Del only clears the contents and may not reset the
Worksheet.UsedRange property; Clear All will facilitate resetting the .Used Range on the next save.
If you have hooped your computer with one or more Excel [Not Responding] scenarios, reboot your machine. Excel never fully recovers from these and simply restarting Excel to start over is slower and more likely to enter the same Not Responding condition later.
¹ If you can convert the late binding of the Scripting.Dictionary to early binding, you must add Microsoft Scripting Runtime to the VBE's Tools ► References.
² Volatile functions recalculate whenever anything in the entire workbook changes, not just when something that affects their outcome changes. Examples of volatile functions are INDIRECT, OFFSET, TODAY, NOW, RAND and RANDBETWEEN. Some sub-functions of the CELL and INFO worksheet functions will make them volatile as well.
Try this Vba-code (and learn a little bit Dutch)
Sub DuplicatesInColumn()
'maakt een lijst met de aangetroffen dubbelingen
Dim LaatsteRij As Long
Dim MatchNr As Long
Dim iRij, iKolom, iTeller, Teller As Long, ControlKolom As Long
iRij = 1
iKolom = 5 'number of columns in the sheet, Chance if not correct
ControlKolom = 4 'column number where to find the doubles, Chance if not correct
LaatsteRij = Cells(65000, iKolom).End(xlUp).Row: iTeller = iKolom
Sheet1.Activate
For iRij = 1 To LaatsteRij
If Cells(iRij, ControlKolom) <> "" Then
MatchNr = WorksheetFunction.Match(Cells(iRij, ControlKolom), Range(Cells(1, ControlKolom), Cells(LaatsteRij, ControlKolom)), 0)
If iRij <> MatchNr Then
iTeller = iKolom
For Teller = 1 To iTeller
Cells(iRij, iKolom + Teller).Offset(0, 2).Value = Range(Cells(iRij, Teller), Cells(iRij, Teller)).Value
Next Teller
End If: End If
Next
End Sub
Please be aware that I am working with a series of ~1000 line medical information databases. Due to the size of the databases, manual manipulation of the data is too time consuming. As such, I have attempted to learn VBA and code an Excel 2010 macro using VBA to help me accomplish parsing certain data. The desired output is to split certain characters from a provided string on each line of the database as follows:
99204 - OFFICE/OUTPATIENT VISIT, NEW
will need to be split into
Active Row Active Column = 99204 ActiveRow Active Column+3 = OFFICE/OUTPATIENT VISIT, NEW
I have researched this topic using Walkenbach's "Excel 2013: Power Programming with VBA" and a fair amount of web resources, including this awesome site, but have been unable to develop a fully-workable solution using VBA in Excel. The code for my current macro is:
Sub EasySplit()
Dim text As String
Dim a As Integer
Dim name As Variant
text = ActiveCell.Value
name = Split(text, "-", 2)
For a = 0 To 1
Cells(1, a + 3).Value = Trim(name(a))
Next a
End Sub
The code uses the "-" character as a delimiter to split the input string into two substrings (I have limited the output strings to 2, as there exists in some input strings multiple "-" characters). I have trimmed the second string output to remove leading spaces.
The trouble that I am having is that the output is being presented at the top of the activesheet, instead of on the activerow.
Thank you in advance for any help. I have been working on this for 2 days and although I have made some progress, I feel that I have reached an impasse. I think that the issue is somewhere in the
Cells(1, a + 3).Value = Trim(name(a))
code, specifically with "Cells()".
Thank you Conrad Frix!
Yah.. funny enough. Just after I post I have a brainstorm.. and modify the code to read:
Sub EasySplit()
Dim text As String
Dim a As Integer
Dim name As Variant
text = ActiveCell.Value
name = Split(text, "-", 2)
For a = 0 To 1
ActiveCell.Offset(0, 3 + a).Value = Trim(name(a))
Next a
End Sub
Not quite the colkumn1,column4 output that I want (it outputs to column3,column4), but it will work for my purpose.
Now I need to incorporate a loop so that the code runs on each successive cell in the column (downwards, step 1) skipping all bolded cells, until it hits an empty cell.
Modified answer to modified request.
This will start on row 1 and continue until a blank cell is found in column A. If you would like to start on a different row, perhaps row 2 if you have headers, change the
i = 1
line to
i = 2
I added a check on the upper bound of our variant before doing the output writes, in case the macro is run again on already formatted cells. (Does nothing instead of erroring out)
Sub EasySplit()
Dim initialText As String
Dim i As Double
Dim name As Variant
i = 1
Do While Trim(Cells(i, 1)) <> ""
If Not Cells(i, 1).Font.Bold Then
initialText = Cells(i, 1).text
name = Split(initialText, "-", 2)
If Not UBound(name) < 1 Then
Cells(i, 1) = Trim(name(0))
Cells(i, 4) = Trim(name(1))
End If
End If
i = i + 1
Loop
End Sub
just add a variable to keep track of the active row and then use that in place of the constant 1.
e.g.
Dim iRow as Integer = ActiveCell.Row
For a = 0 To 1
Cells(iRow , a + 3).Value = Trim(name(a))
Next a
Alternate method utilizing TextToColumns. This code also avoids using a loop, making it more efficient and much faster. Comments have been added to assist with understanding the code.
EDIT: I have expanded the code to make it more versatile by using a temp worksheet. You can then output the two columns to wherever you'd like. As stated in your original question, the output is now to columns 1 and 4.
Sub tgr()
Const DataCol As String = "A" 'Change to the correct column letter
Const HeaderRow As Long = 1 'Change to be the correct header row
Dim rngOriginal As Range 'Use this variable to capture your original data
'Capture the original data, starting in Data column and the header row + 1
Set rngOriginal = Range(DataCol & HeaderRow + 1, Cells(Rows.Count, DataCol).End(xlUp))
If rngOriginal.Row < HeaderRow + 1 Then Exit Sub 'No data
'We will be using a temp worksheet, and to avoid a prompt when we delete the temp worksheet we turn off alerts
'We also turn off screenupdating to prevent "screen flickering"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Move the original data to a temp worksheet to perform the split
'To avoid having leading/trailing spaces, replace all instances of " - " with simply "-"
'Lastly, move the split data to desired locations and remove the temp worksheet
With Sheets.Add.Range("A1").Resize(rngOriginal.Rows.Count)
.Value = rngOriginal.Value
.Replace " - ", "-"
.TextToColumns .Cells, xlDelimited, Other:=True, OtherChar:="-"
rngOriginal.Value = .Value
rngOriginal.Offset(, 3).Value = .Offset(, 1).Value
.Worksheet.Delete
End With
'Now that all operations have completed, turn alerts and screenupdating back on
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
You can do this in a single shot without looping using the VBA equivalent of entering this formula, then taking values only
as a formula
=IF(NOT(ISERROR(FIND("-",A1))),RIGHT(A1,LEN(A1)-FIND("-",A1)-1 ),A1)
code
Sub Quicker()
Dim rng1 As Range
Set rng1 = Range([a1], Cells(Rows.Count, "A").End(xlUp))
With rng1.Offset(0, 3)
.FormulaR1C1 = "=IF(NOT(ISERROR(FIND(""-"",RC[-3]))),RIGHT(RC[-3],LEN(RC[-3])-FIND(""-"",RC[-3])-1 ),RC[-3])"
.Value = .Value
End With
End Sub