Remove all character after nth character - excel

I am working on some data organization and need to move information into a form. I have a column of IP addresses and some columns have more than one, or even none. I preferably need to be able to go through the column and keep the first 13 characters and remove everything after it, have 581 lines I need it to be able to run through. I think if I could get a VBA that will run through the column and find the first "," and remove that and anything after it will work. I tried this, but it did nothing.
Sub cleanup()
lastrow = Range("G581").End(xlUp).Row
For i = 2 To lastrow
If Len(Cells(i, 1)) > 13 Then
Cells(i, 1) = Left(Cells(i, 1), 14)
End If
Next i
End Sub

As mentioned before, you are counting the rows in column G, hopefully column G and Column A have the same number of rows.
I'm thinking column G may be the issue.
lastrow = Range("A581").End(xlUp).Row
For i = 2 To lastrow
If Len(Cells(i, 1)) > 13 Then
Cells(i, 1) = Left(Cells(i, 1), 14)
End If
Next i

Honestly there could be a few reasons that you're having trouble. The big one is that when you use the Left() function, you tell it to keep 14 characters instead of the 13 you said that you want!
Another option could be that excel thinks you are trying to do this operation on another sheet. To combat this one, I made a worksheet object and qualified all of the ranges mentioned just to be sure that excel knows what location you're talking about.
An (unlikely based on your description, but possible) problem could be with the way that you specify the lastrow. If you have a column of contiguous values (although your description would suggest you do not) and you specify the last row of that column with a value, the .End(xlUp) will actually trace back up to the last cell with no value which could be the first row - so the loop never even runs! You could avoid this just by changing it to lastrow = Range("G582").End(xlUp).Row (one row below what you know to be the last full row), but why bother when you can just let excel do the work for you like in my answer below.
Sub cleanup()
Dim ws As Worksheet
Set ws = sheets("Sheet1")
Dim lastRow As Long
lastRow = ws.Range("G" & rows.count).End(xlUp).row
Dim i As Long
For i = 2 To lastRow
If Len(ws.Cells(i, 1)) > 13 Then
ws.Cells(i, 1) = Left(ws.Cells(i, 1), 13)
End If
Next i
End Sub
I also made a version with the second option that you mentioned in the question about splitting each row by a comma ",".
Sub cleanup2()
Dim ws As Worksheet
Set ws = sheets("Sheet1")
Dim lastRow As Long
lastRow = ws.Range("G" & rows.count).End(xlUp).row
Dim i As Long
For i = 2 To lastRow
ws.Cells(i, 1) = Split(ws.Cells(i, 1), ",")(0) 'option 2
Next i
End Sub
Hope this solves your problem!

Related

Copy Paste Cell beginning with equal sign (=====)

So my issue is that I have an input sheet that I can't change the formatting of. Unfortunately they used a line of equal signs =========== in a cell for differentiating the sections. I now need to copy/paste certain columns (almost as a whole) including theses "separator cells", however those can't be copied because they aren't recognised as strings. The error msg is Run-time error 1004: Application-defined or object-defined error, which is guess stems from the fact that I want to copy paste a cell with an equal sign in the front, so normally a formula. The columns also include different data types, so I can't really force everything to be a string. How can I skip these or even better copy/paste them into my other worksheet?
My problem is a very isolated issue so I'll just give the relevant lines of code. For context: wksh and wksh2 are declared worksheets, LastRow is the declared last row of the column, etc. It works for other columns, just not the one's with these ======== cells.
Dim arrC As Variant
arrC = wksh.Range("A2:" & LastRow)
wksh2.Range("A2").Resize(UBound(arrC), 1).Value = arrC
First note that "A2:" & LastRow is no valid address as the column letter for the second part is missing. It needs to be something like "A2:A" & LastRow
First Option
One option is to loop through the array and test each element if it begins with = and replace it with '= (the apostroph is not shown but ensures that it is handled as text and not as formula). Note that this will kill all formulas in that range.
Dim arrC As Variant
arrC = wksh.Range("A2:A" & LastRow).Value
Dim iRow As Long
For iRow = 1 To UBound(arrC, 1)
Dim iCol As Long
For iCol = 1 To UBound(arrC, 2)
If Left$(arrC(iRow, iCol), 1) = "=" Then
arrC(iRow, iCol) = "'" & arrC(iRow, iCol)
End If
Next iCol
Next iRow
wksh2.Range("A2").Resize(UBound(arrC), 1).Value = arrC
Second Option
The second option is to set the number format of the destination to text: .NumberFormat = "#" then paste the values and turn it back to general.
Dim arrC As Variant
arrC = wksh.Range("A2:A" & LastRow).Value
With wksh2.Range("A2").Resize(UBound(arrC), 1)
.NumberFormat = "#"
.Value = arrC
.NumberFormat = "General"
End With
Note that .NumberFormat = "#" will turn also numbers into text so you need to turn it back to General to ensure that if there were numbers they are turned back to numbers again and you can calculate with them.
This workaround might have some odd effects on dates or other number formats. So this might not be a reliable solution depending on what data you have.
Third Option
Last option is .Copy and .PasteSpecial
wksh.Range("A2:A" & LastRow).Copy
wksh2.Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
'or without number formats
wksh2.Range("A2").PasteSpecial xlPasteValues
Are you performing any special operation post loading the data into an array? If not then I'd suggest using simple copy and paste routine through VBA which should work reliably.
Public Sub CopyPasteData()
Dim wksh As Worksheet, wksh2 As Worksheet
Set wksh = ThisWorkbook.Sheets(1)
Set wksh2 = ThisWorkbook.Sheets(2)
wksh.Range("A2:" & LastRow).Copy wksh2.Range("A2")
End Sub

fastest way to process 115 million cells?

I have been given a work task where im to find and replace 8 digits numbers with a corresponding new values coming from a 2 column table....basically a vlookup then replace the old value with a new one...
The challenge im facing is.... the 2 column table is 882k rows, and the cells im trying to replace is about 120 million (41,000 rows x 3000 columns)...
I tried running a vba code i found somewhere...
Option Explicit
Sub Replace_Overwrite()
Dim LRow As Long, i As Long
Dim varSearch As Variant
With Sheets("Sheet2")
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
varSearch = .Range("A2:B" & LRow)
End With
With Sheets("Sheet1").UsedRange
For i = LBound(varSearch) To UBound(varSearch)
.Replace what:=varSearch(i, 1), replacement:=varSearch(i, 2), lookat:=xlWhole
Next
End With
End Sub
I tried using this and it ran it for 8 hours and my work laptop crashed....
I'm not sure anymore if this is still possible with MS Excel alone...
I wonder if anyone can help me with a code that can process it.. i can leave my system open over the weekend if its stable and does work.. it only has 8GB ram btw, running excel 2013...
To speed up things, do as much as possible in memory and minimize the interaction between VBA and Excel (as this makes things really slow).
The following attempt reads the lookup-list into a dictionary and then processes the data column by column.
I did a test, creating 880.000 lookup rows and 40.000 x 100 cells of data. Building the dictionary took less than a minute, processing the columns took 3-4 seconds per column. I added a logic that after every 10 columns, the whole workbook is saved, that increased the processing time but ensures that after a crash you can more or less continue where you left (the yellow color tells you where, just replace the 1 in for col=1 with the column where you want to restart).
I have added some DoEvents, that in theory slows down the process a little bit. Advantage is that you can see the output of the debug.print and the whole Excel process is not displayed as unresponsive in the task manager.
To build the dictionary, I read the complete data into an array at once (if you are not familiar with Dictionaries: You need to add a reference to the Microsoft Scripting Runtime).
Function createDict() As Dictionary
Dim d As New Dictionary
Dim rowCount As Long
Dim list()
Debug.Print Now, "Read data from Lookup sheet"
With ThisWorkbook.Sheets(1)
rowCount = .Cells(.Rows.Count, 1).End(xlUp).row
list = .Range("A1:B" & rowCount).Value
End With
Debug.Print Now, "Build dictionary."
Dim row As Long
For row = 1 To UBound(list)
If Not d.Exists(list(row, 1)) Then d.Add list(row, 1), list(row, 2)
If row Mod 1000 = 0 Then DoEvents
Next row
Set createDict = d
End Function
As said, replacing the data is done column by column. Again, I read the whole column at once into an array, do the replace on this array and then write it back to the sheet.
Sub replaceAll()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim d As Dictionary
Set d = createDict
Dim row As Long, col As Long
Dim rowCount As Long, colCount As Long
With ThisWorkbook.Sheets(2)
rowCount = .Cells(.Rows.Count, 1).End(xlUp).row
colCount = .Cells(1, .Columns.Count).End(xlToLeft).Column
For col = 1 To colCount
Debug.Print Now & "processing col " & col
DoEvents
Dim data
data = .Range(.Cells(1, col), .Cells(rowCount, col))
For row = 1 To rowCount
If d.Exists(data(row, 1)) Then data(row, 1) = d(data(row, 1))
Next row
.Range(.Cells(1, col), .Cells(rowCount, col)) = data
.Cells(1, col).Interior.Color = vbYellow
If col Mod 10 = 0 Then ThisWorkbook.Save
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
One remark: You should consider to use a database for such amount of data.

Copy paste specific cell values from one work sheet to another based on a specific criteria

Its been a while since I have done any sort of coding, so I am very rusty.
I am trying to write some VBA code, so that when a button is clicked in the excel sheet it will check another sheet in the same workbook and copy of specific cell values. This is based on a criteria in one of the columns (column 15, I counted); I should probably add that the data is in a table. if that row meets the specified criteria from column 15, then specific columns are copied over to the worksheet with the button.
I do have some code, but I know there is a lot missing from it.
Would appreciate some input, am I on the right track? can anyone help on there I can get more info and tips on the coding I need to use. Not sure if there is an easy way to do this using tables?
Private Sub CommandButton1_Click()
''This will count how many rows are populated in the table''
a = Worksheets("Billable").Cells(Rows.Count, 1).End(xlUp).Row
''Loop will run from row 6 to the last row (Row 6 is the first row in table)''
For i = 6 To a
''If statement which will check the status column for Detailed Estimate Submitted > column 15''
If Worksheets("Billable").Cells(i, 15).Value = "Detailed Estimate Submitted" Then
Worksheets("Billable").Rows(i).Copy
Worksheets("PM_Forecast").Activate
b = Worksheets("PM_Forecast").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("PM_Forecast").Cells(a + 1, 1).Select
ActiveSheet.Paste
End If
Next
Application.CutCopyMode = False
End Sub
An example of the table: -
I only need to copy over 3 of the columns if they meet a specific criteria in the status column
You did not answer my question regarding the format pasting...
So, please, test the next code which pastes on a classical way. But without selecting and declaring all used variables:
Private Sub CommandButton1_Click()
Dim shB As Worksheet, shPM As Worksheet, lastRowB As Long, lastRowPM As Long
Dim i As Long, lastCol As Long
Set shB = Worksheets("Billable")
Set shPM = Worksheets("PM_Forecast")
lastRowB = Worksheets("Billable").Cells(Rows.Count, 1).End(xlUp).row
'Loop will run from row 6 to the last row (Row 6 is the first row in table)''
For i = 6 To lastRowB
If shB.Cells(i, 15).Value = "Detailed Estimate Submitted" Then
lastCol = shB.Cells(i, Columns.Count).End(xlToLeft).Column
lastRowPM = shPM.Cells(Rows.Count, 1).End(xlUp).row
shB.Range(shB.Range("A" & i), shB.Cells(i, lastCol)).Copy _
shPM.Cells(lastRowPM + 1, 1)
End If
Next
Application.CutCopyMode = False
End Sub
For array using variant you must only declare a new variable Dim arr As Variant and replace this part:
shB.Range(shB.Range("A" & i), shB.Cells(i, lastCol)).Copy _
shPM.Cells(lastRowPM + 1, 1)
with this one:
arr = shB.Range(shB.Range("A" & i), shB.Cells(i, lastCol)).Value
shPM.Cells(lastRowPM + 1, 1).Resize(, UBound(arr, 2)).Value = arr
Then, delete the code line Application.CutCopyMode = False. It is not necessary, anymore, since the Clipboard memory is not used...
And use Option Explicit on top of your module. It will save you many times, when the code will become complex.
I cant comment so I will ask the question through this answer:
Your variable b is currently not being used, I think it was meant to be in this line: Worksheets("PM_Forecast").Cells(b + 1, 1).Select but you have written a instead of b.
Does this solve your current issue?

Excel VBA - Add rows as described in a table

I am trying to replicate this view where new rows in the bottom table are created based on the values in Column'A' of the top table.
Here is my code:
Sub testProc()
Worksheets("Sheet1").Activate
Dim r, count As Range
Dim LastRow As Long
Dim temp As Integer
'Dim lngLastRow As Long
Set r = Range("A:L")
Set count = Range("A:A")
LastRow = Range("F" & 9).End(xlUp).Row
'LastRow = Cells(Rows.count, MyRange.Column).End(xlUp).Row
For n = LastRow To 1 Step -1
temp = Range("A" & n)
If (temp > 0) Then
Rows(n + 1 & ":" & n + temp).Insert Shift:=xlDown
Range("H" & (ActiveCell.Row) - 2).Copy Range("E" & (ActiveCell.Row) - 1)
Range("G" & (ActiveCell.Row)).Select
'ActiveCell.Offset(RowOffset:=1, ColumnOffset:=-6).Activate
'Cells(ActiveRow, 8).Value.Cut
'Cells.Offset(2 - 6).Value.Paste
'Range("G" & (ActiveCell.Row)).Select
'ActiveCell.Offset(0 - Selection.Column + 1).Range("A1:AG1").Select
'Value = Range(G, H)
'ActiveCell.Offset(1, -6).Paste
'ActiveCell.Offset(1, -6).Paste
'ActiveCell.Offset(RowOffset:=1, ColumnOffset:=-6).Paste
'Range.Offset(1, -6).Paste
'Value = Range("G" & (ActiveCell.Row), "H" & (ActiveCell.Row)).Value
'ActiveCell.Offset(2, -6).Range
'ActiveCell.Offset(rowOffset:=3, columnOffset:=3).Activate
End If
Next n
End Sub
I do not know what I am doing and Excel is crashing with and without messages
The easiest solution to this would be to use two separate worksheets, but you can work around this pretty easily with some math or a cell with a reserved word. You also want to use as few reference variables as possible and let Excel tell you what the ranges are defined as by using contiguous ranges.
I'm not going to write the whole function for you, but give you the building blocks that will let you piece it together and hopefully you'll learn more as you do it.
Here's how to set up the object variables that you'll reference throughout the code:
Dim sourceSheet as Worksheet
Dim targetSheet as Worksheet
' replace with the names of sheets you want to use
sourceSheet = Worksheets("Sheet1")
targetSheet = Worksheets("Sheet2")
Now, for looping through the source table. If you know that the first row in the Sheet is always the Title row and your instructions start in row 2 then you can use this to loop through every instruction:
Dim sourceRowIndex = 2
While Not IsEmpty(sourceSheet.cells(sourceRowIndex, 1))
' ** do stuff here
' increment row index
sourceRowIndex = sourceRowIndex + 1
Wend
You could also use a For Each loop or a For Next or a Do While, take your pick once you understand the logic used.
Note that "Cells" takes two numbers - the row number then the column number. This is very handy when you're looping through a series of rows and columns and don't want to have to deal with addresses like A1 or C5.
This will loop through everything in the top table, but now you need to add an inner loop that will actually process the instructions. Add all of the code below after the While and before the Wend.
Finally, you need to add the rows to the Target. The trick here is to use the CurrentRegion property to figure out where the last row in the range is, then just add one to get the next blank row.
Dim targetFirstEmptyRow
' Look up the Current Range of cell A1 on target worksheet
targetFirstEmptyRow = targetSheet.cells(1,1).CurrentRegion.Rows + 1
Then to assign values don't use copy and paste, just assign the values directly. This will write the first row you have defined:
targetSheet.cells(targetFirstEmptyRow, 1).value = sourceSheet.cells(sourceRowIndex, 1).value
targetSheet.cells(targetFirstEmptyRow, 4).value = sourceSheet.cells(sourceRowIndex, 4).value
targetSheet.cells(targetFirstEmptyRow, 5).value = sourceSheet.cells(sourceRowIndex, 5).value
Then after you write out those three values you can get the next empty row by using this again (note that your sourceRowIndex hasn't changed):
targetFirstEmptyRow = targetSheet.cells(1,1).CurrentRange.Rows + 1
Using the cells(row, column) logic it's pretty easy to write the second row as well:
targetSheet.cells(targetFirstEmptyRow, 2).value = sourceSheet.cells(sourceRowIndex, 6).value
targetSheet.cells(targetFirstEmptyRow, 3).value = sourceSheet.cells(sourceRowIndex, 7).value
targetSheet.cells(targetFirstEmptyRow, 6).value = "Dev"
Adding the third row (when it's required) is nearly exactly the same as the second. However, you want to check to see if the third row is necessary:
If sourceWorksheet.cells(sourceRowIndex, 1) = 3 Then
' insert your third row here
End If
Here's the entire function in pseudo-code so you can piece it all together:
Set up worksheet variables
While loop through every Source row
Find next empty row in Target
Copy Row 1
Find next empty row in Target
Copy Row 2
If 3 rows
Find next empty row in Target
Copy Row 3
Increment Source Row Index
Wend
Finally, if you don't want to see the screen flashing (and you want to speed the code execution up a little) look into Application.Screenupdating to turn off screen redraw as this does its work. Just remember to turn it on again once you've finished processing everything.

Excel adding values from columns that start with the same word?

My colleagues at work seem to spend a lot of time getting data from spreadsheets and having to work out percentages then paste it into a report.
I'm pretty sure there is a quicker way but it's proving difficult with little experience with Ecxel.
Excel Spreadsheet
I have already created a Macro to remove any unnecessary text in the fields so it is now just a value.
My problem is that there is always a different number of fields that I need to get data from.
The field I need the values from is the one directly under any field that starts with "Unique Pulls" Once I can work this out, the rest should be pretty straight forward.
I'm just starting out with VBA myself so not 100% sure, but perhaps you could use a Find/FindNext loop?
This might be helpful on using Find/FindNext (example in 'Section 3'): http://www.siddharthrout.com/2011/07/14/find-and-findnext-in-excel-vba/
Hope that helps with getting you started!
edit:
Maybe you've already solved this from the comments above, but in case you are still having issues with adding up values here's a potential solution I've been playing with: all credit to #Alex K. for the UCase$(cell.Value) suggestion above!
Dim LastRow As Integer, LastCol As Integer
Dim iTotal As Integer, n As Integer, i As Integer
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
For n = 2 To LastRow ' For each row with data...
iTotal = 0 ' Resets total count for each row.
For i = 1 To LastCol ' Find each column starting with 'Unique Pulls'.
If UCase$(ActiveSheet.Cells(1, i).Value) Like "UNIQUE PULLS*" Then
iTotal = iTotal + ActiveSheet.Cells(n, i).Value
' For each of these columns, take value and add to total sum
End If
Next i ' Move onto next column
ActiveSheet.Cells(n, 5).Value = iTotal
'REPLACE 5 WITH COLUMN NUMBER OF TOTAL PULLS
Next n ' Move onto next row
Perhaps?
This looks at each header in A:A and msgboxes the value under any cell beginning with your search text:
Dim cell As Range: Set cell = Range("A1")
Do While cell.Value <> ""
If UCase$(cell.Value) Like "UNIQUE PULLS*" Then
MsgBox cell.Offset(1, 0).Value
End If
Set cell = cell.Offset(0, 1)
Loop

Resources