I am facing a minor issue, basically I have successfully done the macro process for one string. But I am unable to process the same vba macro for keeping multiple strings and delete the unwanted data present in the CSV file.
Currently the below code only keeps the rows with string Event Magnitude: and deletes the rest.
However I want to add multiple strings like Event Duration:,
Trigger Date:, Trigger Time: in the same macro and I am unsure how to do it.
IF I can add multiple strings this macro will check for all 4 strings and keep that data and delete the rest of the data.
Sub DeleteNotMIS()
Dim r As Long, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For r = lr To 2 Step -1
If InStr(Cells(r, 1), "Event Magnitude: ") = 0 Then Rows(r).Delete
Next r
End Sub
You need to define a list of keywords to keep KeywordsToKeep = Array("Event Magnitude: ", "Trigger Date:") and then check in another loop each keyword
Option Explicit
Public Sub DeleteNotMIS()
Dim LastRow As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim KeywordsToKeep() As Variant
KeywordsToKeep = Array("Event Magnitude: ", "Trigger Date:") 'Add other keywords here
Dim iRow As Long, eKey As Variant, FoundKey As Boolean
For iRow = LastRow To 2 Step -1
FoundKey = False 'initialize
For Each eKey In KeywordsToKeep
If InStr(Cells(iRow, 1), eKey) <> 0 Then
FoundKey = True
Exit For 'we don't need to check further keys if we already found one.
End If
Next eKey
If Not FoundKey Then Rows(iRow).Delete
Next iRow
End Sub
If each keyword can occur only once in the CSV file …
this approach is slow, because it has to check every row (row by row). A faster approach then would be to use the Range.Find method to find each keyword directly and extract/copy it to a new sheet.
Related
I have a program that can generate a set of data that will end up formatted like this example.
Sample Data
I want to pull values from this data and generate text in a text file by using an Excel macro. I have figured out how to edit the text file in the manner I need to, but I am having a lot of trouble actually moving through the data.
I'm not sure my actual code will be that helpful because it's really not functional. Instead I'll try to annotate it with how I was thinking. I'm not experienced with VBA or programming in general and I think what I actually tried without any annotation would hurt more than it would help.
Sub Macro2()
'Declare variables
Dim DIRECTORY As String
Dim SCRPATH As String
Dim COORD As String
Dim PART as String
'Define where txt file is located (it will always be in same location as workbook and have the same name)
DIRECTORY = ActiveWorkbook.Path
SCRPATH = DIRECTORY & "\sample.txt"
'The data being read will always be on the same sheet
With Sheet1
For Each row In Range("A2:A500")
'For each row below the headings, loop through and do the same set of actions
'I have this set as A2:A500 because I know for sure there will never be more than 500 rows of data
'Would it be better to count the rows that have data and then repeat the loop that many times?
'There should never be blank rows breaking up the data
If Not IsEmpty(ActiveCell.Value) Then
'If there is data in that row, then continue. If there is no data, end the macro
For Each col In Range("F:J")
If Not IsEmpty(ActiveCell.Value) Then
'For every cell with data in the F to J columns, perform an action. When there is no more data, move to the 'next row
COORD = ActiveCell.Value
'Set COORD to the value of the cell so that it can be printed to the text file
Open SCRPATH For Append As #1
Print #1, COORD
Close #1
End If
Next
End If
Next
End With
End Sub
This ended up looping forever and causing my excel to crash. I believe that is because there is nothing that ever tells the active cell to move. I am unsure of the best way to go about moving the active cell, however. I would also like to print the value in the "part" cell but am unsure of the best place to put that function.
Sample Output
This is what I would like my output to look like, for all rows of data.
Using VBA, it's very rare you need to use active cell to get the value.
Sub Macro2()
Dim ws As Worksheet, fso, ts, n As Long
Dim lastrow As Long, lastcol As Long, i As Long, j As Long
Dim DIRECTORY As String, SCRPATH As String
DIRECTORY = ActiveWorkbook.Path
SCRPATH = DIRECTORY & "\sample.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.createTextFile(SCRPATH)
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastrow
ts.writeline .Cells(i, "B")
lastcol = .Cells(i, .Columns.Count).End(xlToLeft).Column
For j = 6 To lastcol
ts.writeline .Cells(i, j)
n = n + 1
Next
ts.writeline ""
n = n + 2
Next
End With
ts.Close
MsgBox n & " lines written to " & SCRPATH, vbInformation
End Sub
I am trying to write a VBA code where I want to populate DATA from a worksheet Range A to AQ spanning over multiple Rows. AQ contains Value "Open" or "Closed". I want to get the rows where AQ value is closed. I tried using the AutoFilter. This is working fine to an extent. But I have to use 2 For loops. One for Each Row and another for Each Column to populate Row wise, column by column into the list box
My Code as follows:
Note : Actual contents start from 6th Row where 6 contains the headers and data starts from 7th Row
Dim i As Long
Dim rowRange As Range
Dim AllData(1 To 1000, 1 To 43) As String
lstRecords.ColumnCount = 43
Set shDSR = mydata1.Sheets("DSR")
last_Row = shDSR.Cells(Rows.Count, 1).End(xlUp).Row
shDSR.AutoFilterMode = False
shDSR.Range("A6:AQ" & last_Row).AutoFilter Field:=43, Criteria1:="CLOSED"
Set rng = shDSR.Range("A6:AQ" & last_Row).SpecialCells(xlCellTypeVisible)
Dim filtrRow() As String
Dim rowCnt As Long
'Me.lstRecords.Clear
rowCnt = 0
If rng.Count > 0 Then
Me.lstRecords.Clear
Me.lstRecords.ColumnCount = rng.Columns.Count
For Each Row In rng.Rows
Me.lstRecords.AddItem
rowCnt = rowCnt +1
filterRow = Range(Row.Address)
'Me.lstRecords.List() = filterRow ''This throws error Type Mismatch so not using
For i = 1 To Row.Columns.Count
AllData(rowCnt, i) = Row.Cells(1, i).Value ''Move to Array
Me.lstRecords.List(rowCnt - 1, i - 1) = filterRow(1, i)'Buggy error when i = 11
Next
Next
'' Following segment works. Add data to Array and then populate ListBox from Array
Me.lstRecords.List() = AllData
Else
MsgBox "No data matches the filter criteria."
End If
Above Code has both approaches
a) Trying to load directly from excel Range (actually using filterRow, but can also directly use range with same issue). But, this approach stops always when i=11 with Invalid property error. I tried changing the data contents etc still same issue
Another Issue when Not taking the array based approach, only one line is added, so in affect only last line is available in the list box
b) Using the AllData array. I load all the row data (matching criteria) into the array and finally populate the listbox from array. THIS WORKS. But I do not like this approach
Can some one please point out where it is going wrong.
Thanks in advance
Problem is that filters create a non contiguous range consisting of areas which you have to iterate separately.
Option Explicit
Sub demo()
Dim mydata1 As Workbook, shDSR As Worksheet
Dim rng As Range, a As Range, r As Range
Dim last_row As Long, n As Long
Dim i As Long, rowCnt As Long
Dim ListData() As String
' change this
Set mydata1 = ThisWorkbook
Set shDSR = mydata1.Sheets("DSR")
With shDSR
.AutoFilterMode = False
last_row = .Cells(.Rows.Count, "AQ").End(xlUp).Row
.Range("A6:AQ" & last_row).AutoFilter Field:=43, Criteria1:="CLOSED"
Set rng = .Range("A6:AQ" & last_row).SpecialCells(xlCellTypeVisible)
.AutoFilterMode = False
End With
' clear listbox
With Me.lstRecords
.Clear
.ColumnCount = rng.Columns.Count
End With
'iterate areas and rows to count visible rows
For Each a In rng.Areas
n = n + a.Rows.Count
Next
rowCnt = 0
If n > 1 Then
' size array
ReDim ListData(1 To n, 1 To rng.Columns.Count)
' fill array
For Each a In rng.Areas
For Each r In a.Rows
rowCnt = rowCnt + 1
For i = 1 To UBound(ListData, 2)
ListData(rowCnt, i) = r.Cells(1, i).Value ''Move to Array
Next
Next
Next
' populate ListBox from Array
Me.lstRecords.List() = ListData
Else
MsgBox "No data matches the filter criteria."
End If
End Sub
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.
First time using the site as I am new to VBA, but I am trying to write a piece of code that will look through a column of my choice, in this case column A, and go through each row and delete empty rows until the end of the dataset. I was thinking of doing a loop where I would reference the first cell in my dataset A1 and set the row number as a integer which would increase by 1 with each completion of the loop.
Private Sub CommandButton1_Click()
Dim X as Integer
Set X = 1
For X = 1 to 100
If Sheet1.Range("A":X).Value = "" Then Rows(X).EntireRow.Delete
Next X
End Sub
Thanks for any help or insights you can provide!
You want to concatenate in Range("A":X) so change : to & (or use cells).
When deleting rows you should step backwards or create a unionized range otherwise you will skip a row with every deletion you perform.
You don't want to set integers that is only for objects. There is also no benefit from using integer over long in VBA so best to just always use long as integer can give overflow errors in very large spreadsheets.
Rows(X).EntireRow.Delete is using a relative reference not an explicit one, use a with or explicitly reference every range object.
You are immediately overwriting X with the loop so you don't need to assign it a value before the loop.
Here's some code that will do what you need:
Dim lastrow As Long
Dim x As Long
With Sheet1
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
For x = lastrow To 1 Step -1
If .Cells(x, 1).Value = "" Then
.Rows(x).EntireRow.Delete
End If
Next x
End With
You are missing your "End if". Also when looping through a range and deleting rows you need to loop bottom up because when a row is deleted it does not recalculate the range.
Sub CommandButton1_Click()
Dim x As Long
Dim lastrow As Long
lastrow = Range("A1" & Rows.Count).End(xlUp).Row
For x = lastrow To 1 Step -1
If Worksheets(1).Range("A" & x).Value = "" Then
Worksheets(1).Range("A" & x).EntireRow.Delete
End If
Next x
End Sub
I have a rather silly problem. I have a macro (linked to a button) which copies cells A1:A2 from one worksheet (namedFP) to another worksheet (Log). I intend to copy these 2 cells on the log sheet every time I hit the macro button. The problem I am facing right now is that when I use the button multiple times, these cells are getting copied over each other instead of using the next available row to paste the cells.
This is what I have now, and I tried changing the 'Rowcount+1' to 'RowCount+2' but that did not work. Any help is appreciated.
DHRSheet.Select
Range("A1:A2").Select
Selection.Copy
LogSheet.Select
RowCount = LogSheet.UsedRange.Rows.Count
Dim r As Integer
r = RowCount + 1
Dim infocell As Range
Set infocell = Cells(r, 1)
infocell.Select
ActiveSheet.Paste
infocell.Value = DHRSheet.Name & "$" & infocell.Value
DHRSheet.Select
ActiveWorkbook.Save
Is this what you are trying?
Sub Sample()
Dim LogSheet As Worksheet, DHRSheet As Worksheet
Dim lrow As Long
'~~> Change this as applicable
Set LogSheet = Sheets("Sheet1")
Set DHRSheet = Sheets("Sheet2")
With LogSheet
lrow = LogSheet.Range("A" & .Rows.Count).End(xlUp).Row + 1
DHRSheet.Range("A1:A2").Copy .Range("A" & lrow)
End With
End Sub
Here's a function I use that is very reliable and always returns the last row of a sheet without fail:
(possibly excessive for your simple use, but I always recommend it)
Public Function LastRowOfSheet(ByVal TestSheetNumber As Variant)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Input: Sheet index # or Sheet name
' Output: Last row of sheet.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim intNumberOfRowsInWorksheet As Long
intNumberOfRowsInWorksheet = Sheets(TestSheetNumber).UsedRange.Rows.Count
intNumberOfRowsInWorksheet = intNumberOfRowsInWorksheet + Sheets(TestSheetNumber).UsedRange.Row - 1
LastRowOfSheet = intNumberOfRowsInWorksheet
End Function
And I'd clean up your above code and use something like this:
Sub Move2RowsToEnd()
Dim iNextRowOfOutput As Long
Dim iRowNumber As Long
'- use the function to find the last row of the output sheet. we'll be pasting to the first row after.
iNextRowOfOutput = (LastRowOfSheet("Log") + 1)
'- you can adjust this for loop to loop through additional cells if you need to paste more than 2 rows in the future.
For iRowNumber = 1 To 2
'- for each row of input (2 total) set the value of the output sheet equal to it.
Sheets("Log").Range("A" & iNextRowOfOutput).Value = Sheets("namedFP").Range("A" & iRowNumber).Value
iNextRowOfOutput = iNextRowOfOutput + 1
Next iRowNumber
'- not sure which of these you want to save (one or both)
Sheets("namedFP").Save
Sheets("Log").Save
End Sub
Just paste the function above or below the Subroutine and let me know if you have any issues or questions regarding the 'Move2RowsToEnd' code.