Copy data from one table and Clear and update new data into another table in another sheet in excel 2010 - excel

I have a VBA macro which is currently copying data from Setup sheet and updating into the respective tables into Read_Only sheet for the first time. But when I click second time, it is adding the data into the respective tables in Read_Only sheet.
Now what I want is, if I click second time, it should first clear the existing data from that respective table in Read_Only sheet and then update the new data into that table. (For example: In 1st table, there were 10 rows of data, now when I click 2nd time I have only 8 rows of data, then macro should clear data existing 10 rows of data and update this new 8 rows of data and then delete the 2 empty two rows. This should be Dynamic, since number of rows may vary every time while updating new data)
Here is the existing code:
Sub copyData()
Dim wsSet As Worksheet
Dim wsRead As Worksheet
Dim rngSearch As Range
Dim lastRow As Integer
Dim i As Integer
Dim wRow As Integer
Dim strCat As String
Dim catRow As Integer
Set wsSet = ActiveWorkbook.Worksheets("Budget_Setup")
Set wsRead = ActiveWorkbook.Worksheets("WBS_Overview_Read_only")
Set rngSearch = wsRead.Range("A12:A1000") 'range in READ to search for category
lastRow = wsSet.Range("B16").End(xlDown).Row 'last row of data in SET
Application.ScreenUpdating = False
For i = 17 To lastRow
strCat = Left(wsSet.Range("b" & i).Value, 3) 'current category in SET
catRow = rngSearch.Find(strCat).Row 'row of match in READ
If wsRead.Range("a" & catRow + 1).Value = "" Then 'find the correct row to copy into
wRow = catRow + 1
Else
wRow = wsRead.Range("a" & catRow).End(xlDown).Row + 1
If wsRead.Range("e" & wRow).Value <> "" Then
wsRead.Range("a" & wRow).EntireRow.Insert
End If
End If
wsSet.Range("b" & i & ":f" & i).Copy
wsRead.Range("a" & wRow).PasteSpecial
Application.CutCopyMode = False
Next i
Application.ScreenUpdating = True
Set wsRead = Nothing
Set wsSet = Nothing
End Sub

This code will first delete all the existing data in each of the sections on the Read_Only sheet; then, with one modification, your code can be run as is.
Add this line of code immediately after Application.ScreenUpdating = False
' Erase all data in the Read Only Sheet
Set currentData = wsRead.Columns(4).Find("Subject")
Do
wsRead.Range(currentData.Offset(2, 0), _
currentData.Offset(2, 0).End(xlDown).Offset(-1, 0)).EntireRow.Delete
Set currentData = wsRead.Columns(4).FindNext(currentData)
Loop Until Not currentData Is Nothing And currentData.Row = 12
This code uses the "Subject" and the "Budgeted Cost" cells to delete the existing data between it.
Next, add the following line of code immediately after wRow = catRow + 1
wsRead.Rows(wRow).EntireRow.Insert
this will add the first blank row of data to a given section. Your existing code will then insert the new data into the blank row

See if this works for you. I added one line to your code:
For i = 17 To lastRow
strCat = Left(wsSet.Range("b" & i).Value, 3) 'current category in SET
catRow = rngSearch.Find(strCat).Row 'row of match in READ
If wsRead.Range("a" & catRow + 1).Value = "" Then 'find the correct row to copy into
wRow = catRow + 1
wsRead.Rows(wRow).EntireRow.Insert 'I added this line
Else
wRow = wsRead.Range("a" & catRow).End(xlDown).Row + 1 'end of data
If wsRead.Range("e" & wRow).Value <> "" Then
Now, run this code before running yours.
Sub deletePhases()
' delete phases in Setup from ReadOnly
Dim r As Range, Col As Collection
Dim x As Long, l As Long
With Budget_Setup
Set r = .Range("b17", .Cells(.Rows.Count, 2).End(xlUp))
End With
If r.Row < 17 Then Exit Sub 'no data
Set Col = New Collection 'build unique list
On Error Resume Next
For x = 1 To r.Rows.Count
Col.Add Left(r(x).Value, 3), Left(r(x).Value, 3)
Next x
With ReadOnly
For x = 1 To Col.Count
l = .Columns(1).Find(Col(x)).Offset(1).Row '1 below heading
Do Until .Cells(l, 1) = "" 'end of phase data
.Rows(l).Delete
Loop
Next x
End With
End Sub

I'm not sure how you're defining your Phase.71, Phase.72, etc, ranges, but with the information we have, this might work for you.
Sub clearAll()
Dim r As Range, vArr, v
vArr = Array("Phase.71", "Phase.72", "Phase.73", "Phase.74", "Phase.75")
For Each v In vArr
Set r = ReadOnly.Range(v)
Set r = r.Offset(2).Resize(r.Rows.Count - 4)
r.ClearContents
Next v
End Sub

Related

Loop through and copy paste values without repetition if conditions are met

Im trying to create a table that pulls data from my raw data if certain conditions are met. The code I currently have does not seem to be working.
Public Sub insert_rows()
Dim datasheet As Worksheet
Dim datasheet2 As Worksheet
Dim r As Long
Dim tableA As ListObject
Set tableA = Worksheets(Sheet7).ListObject(Preventable)
Set datasheet = Worksheets(Sheet7)
Set datasheet2 = Worksheets("Data")
With datasheet2
nr = Cells(Rows.Count, 1).End(x1up).Row
For r = 1 To nr
If Cells(r, 17) = "Y" Then
Cells(r, 16).Copy Destination:=Sheets("Sheet7").Range("B4")
End If
Next
End With
End Sub
Basically I have several worksheets and need to pull data from one of them to add to this table in another worksheet. My condition is if the Column in the raw data worksheet contains "Y", then pull cell values into the table of the other worksheet. An image below is an example of the data I want to copy and paste over:
As you can see, they are string values separated by "," and can contain duplicates.
I only want to add just the unique entries into the new table; with no repetition of cells. Anyway I could modify this code to suit those conditions?
You could try something like this:
Public Sub insert_rows()
Dim datasheet As Worksheet
Dim datasheet2 As Worksheet
Dim r As Long, i As Long, nr As Long
Dim tableStartingRow As Long, currenttableitem As Long
Dim stringvalues As Variant
Dim stringseparator As String
Dim valueexists As Boolean
tableStartingRow = 4
stringseparator = ","
Set datasheet = Worksheets("Sheet7")
Set datasheet2 = Worksheets("Data")
With datasheet
currenttableitem = .Cells(.Rows.Count, 2).End(xlUp).Row
End With
With datasheet2
nr = .Cells(.Rows.Count, 16).End(xlUp).Row
For r = 1 To nr
If .Cells(r, 17) = "Y" Then
If InStr(.Cells(r, 16), stringseparator) > 0 Then 'If value contains comma
stringvalues = Split(.Cells(r, 16), stringseparator)
For i = LBound(stringvalues) To UBound(stringvalues)
valueexists = False 'Reset boolean
For x = tableStartingRow To currenttableitem
If datasheet.Range("B" & x).Value = Trim(stringvalues(i)) Then
valueexists = True
Exit For
End If
Next x
If Not valueexists Then
currenttableitem = currenttableitem + 1
datasheet.Range("B" & currenttableitem).Value = Trim(stringvalues(i))
End If
Next i
Else
valueexists = False 'Reset boolean
For x = tableStartingRow To currenttableitem
If datasheet.Range("B" & x).Value = .Cells(r, 16).Value Then
valueexists = True
Exit For
End If
Next x
If Not valueexists Then
currenttableitem = currenttableitem + 1
datasheet.Range("B" & currenttableitem).Value = .Cells(r, 16).Value
End If
End If
End If
Next
End With
End Sub
This code will check each value of the cells and will split the contents by ",". Then compare with the content of the table to see if this value is already in there. In case it is not, it will be added, otherwise omitted.
Also, I notice the use of the Cells inside of a With statement. That was making a reference to the active worksheet. To make reference to the item in the With statement, you need to use .Cells
I hope this will help.

Moving rows from one worksheet to specific worksheets based on keywords found in string in a specific column in master worksheet

I have an Excel worksheet called "Main" which includes a set amount of columns, one of which contains a listing of different codes (CVE's) regarding patches that need to be installed on worksheets based on criteria from the internet.
The codes to search for are not in a set format, other than being in strings containing the code.
I manually created a number of worksheets based on keywords in these strings, that will eventually, contain all the lines from the master sheet, but only those defined by the name of the keyword I want.
For example, I have a worksheet named "Microsoft" that should contain all the rows from the master sheet that refer to Microsoft CVE's, based on a search of the string and finding the word "Microsoft". Same for Adobe and so on.
I created a script to copy the rows, as well as create a new Index sheet that lists the amount of rows found for each keyword that have been copied from the master sheet to the relevant sheet.
And this is where I get lost.
I have 18 worksheets which are also keywords. I can define a single keyword and then copy everything over from the main worksheet for one keyword.
I need a loop (probably a loop within a loop) that reads the worksheet names as defined in the Index, searches for all the relevant rows that contain a CVE regarding that keyword, and then copy the row over to the relevant worksheet that I created into the relevant row on that worksheet.
For example, if I have copied two rows, the next one should be written to the next row and so on, until I have looped through all the worksheet (keyword) names and have reached the empty row after the last name in the Index sheet.
My code, set for only one keyword for a limited run to test works.
I need to loop through all the keywords and copy all the data.
In the end, I want to copy the relevant row from the master worksheet (Main) to the relevant worksheet (based on keyword worksheet name in the Index worksheet), and delete the row after it was copied from the master worksheet.
I should end up with all the data split into the relevant worksheets and an empty (except for headers) master worksheet.
This is what I have so far (from various examples and my own stuff).
Public WSNames() As String
Public WSNum() As Long
Public I As Long
Public ShtCount As Long
Sub MoveBasedOnValue()
Dim CVETitle As String
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim C As Long
Dim D As Long
Dim CountCop As Long
A = Worksheets("Main").UsedRange.Rows.Count
A = A + 1
'Create an index of the worksheet names to work with for moving the data and counting the lines in the WS
ReadWSNames
B = Worksheets(WSNames(2)).UsedRange.Rows.Count
B = B + 1 'Place under the last row for start
'Range to read and scan from
Set xRg = Worksheets("Main").Range("E5:E" & A)
On Error Resume Next
Application.ScreenUpdating = False
'For C = 1 To xRg.Count
For C = 1 To 5
'Read in the string to search from the Main WS
CVETitle = CStr(xRg(C).Value)
'Find if the word we want exists in the string
If InStr(1, CVETitle, WSNames(2)) > 0 Then
xRg(C).EntireRow.Copy Destination:=Worksheets(WSNames(2)).Range("A" & B + 1)
CountCop = Worksheets("Index").Range("B3").Value
CountCop = CountCop + 1
Worksheets("Index").Range("B3").Value = CountCop
'xRg(C).EntireRow.Delete
'If CStr(xRg(C).Value) = WSNames(2) Then
'C = C - 1
'End If
B = B + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Sub ReadWSNames()
ReDim WSNames(1 To ActiveWorkbook.Sheets.Count)
ReDim WSNum(1 To ActiveWorkbook.Sheets.Count)
Dim MyIndex As Worksheet
ShtCount = Sheets.Count
'Read sheetnames and number of lines in each WS into arrays and clear the sheets other than the main one
If Not IndexExists("Index") Then
For I = 1 To ShtCount
WSNames(I) = Sheets(I).Name
If WSNames(I) <> "Main" Then ActiveWorkbook.Worksheets(WSNames(I)).Range("5:10000").EntireRow.Delete
WSNum(I) = Worksheets(WSNames(I)).UsedRange.Rows.Count
WSNum(I) = WSNum(I) - 3
Next I
'Add an index worksheet before the main worksheet and make sure one doesn't exist
Worksheets.Add Before:=Worksheets(1)
ActiveSheet.Name = "Index" 'Give new Ws a name
Application.DefaultSheetDirection = xlLTR 'Make direction suited to English
'Write headers and set parameters
Range("A1").Value = "WS Names"
Range("B1").Value = "Count"
With Range("A1:B1")
.Font.Size = 14
.Font.Bold = True
.Font.Color = vbBlue
End With
Columns("A:B").AutoFit
Columns("B:B").HorizontalAlignment = xlCenter
'Write data from arrays into Index WS
ActiveCell.Offset(1, 0).Select
For I = 1 To ShtCount 'Write values to Index WS
ActiveCell.Value = WSNames(I) 'Write Worksheet name
ActiveCell.Offset(0, 1) = WSNum(I) 'Write number of rows already existing in Ws
ActiveCell.Offset(1, 0).Select 'Move one cell down
Next I
Worksheets("Index").Activate 'Make Index the active ws
Range("A2").Select 'Select first cell to read data from
I = 1
X = 2
Do While Not IsEmpty(Range("A" & X)) 'Read values back into array to make sure i's all there
WSNames(I) = ActiveCell.Value
WSNum(I) = ActiveCell.Offset(0, 1).Value
ActiveCell.Offset(1, 0).Select 'Move one cell down
I = I + 1
X = X + 1
Loop
Worksheets("Main").Activate 'Make Main the active ws
Else 'If Index exists, simply read the data into the arrays
Worksheets("Index").Activate 'Make Index the active ws
Range("A2").Select 'Select first cell to read data from
I = 1
X = 2
Do While Not IsEmpty(Range("A" & X)) 'Read values back into array to make sure i's all there
WSNames(I) = ActiveCell.Value
WSNum(I) = ActiveCell.Offset(0, 1).Value
ActiveCell.Offset(1, 0).Select 'Move one cell down
I = I + 1
X = X + 1
Loop
Worksheets("Main").Activate 'Make Main the active ws
Exit Sub
End If
End Sub
Function IndexExists(sSheet As String) As Boolean
On Error Resume Next
sheetExist = (ActiveWorkbook.Sheets(sSheet).Index > 0)
End Function
Because the CVE strings are not the same, it is not possible to sort them, so there can be a CVE for Microsoft in one row and then a few rows of other CVEs, and the Microsoft again and so on.
I tried to post picture examples of the Index worksheet, the worksheet names, and an example of the data in the lines, but I don't have enough reputation.
So, a few examples (out of over 7,000 lines) of the string data is that is searched for the keyword (column E):
*[MS20-DEC] Microsoft Windows Cloud Files Mini Filter Driver Elevation of Privilege Vulnerability - CVE-2020-17134 [APSB16-04]
*Adobe Flash Player <20.0.0.306 Remote Code Execution Vulnerability - CVE-2016-0964 [MS21-JUN] *
*Microsoft Kerberos AppContainer Security Feature Bypass Vulnerability - CVE-2021-31962
*McAfee Agent <5.6.6 Local Privilege Escalation Vulnerability - CVE-2020-7311
*7-Zip <18.00 and p7zip Multiple Memory Corruption Vulnerabilities - CVE-2018-5996
Scan the sheets for a word and then scan down the strings in sheet Main for that word. Scan up the sheet to delete rows.
update - muliple words per sheet
Option Explicit
Sub SearchWords()
Const COL_TEXT = "E"
Const ROW_TEXT = 5 ' first line of text
Dim wb As Workbook
Dim ws As Worksheet, wsMain As Worksheet, wsIndex As Worksheet
Dim arData(), arDelete() As Boolean
Dim lastrow As Long, i As Long, n As Long, r As Long
Dim word As String, txt As String
Dim t0 As Single: t0 = Timer
Dim w
' create index if not exists
CreateIndex
Set wb = ActiveWorkbook
With wb
Set wsMain = .Sheets("Main")
Set wsIndex = .Sheets("Index")
End With
' copy strings into array for speed
With wsMain
lastrow = .Cells(.Rows.Count, COL_TEXT).End(xlUp).Row
If lastrow < ROW_TEXT Then
MsgBox "No text found in column " & COL_TEXT, vbCritical
Exit Sub
End If
arData = .Cells(1, COL_TEXT).Resize(lastrow).Value2
ReDim arDelete(1 To lastrow)
End With
' scan main for each keyword in index
i = 2 ' index row
Application.ScreenUpdating = False
For Each ws In wb.Sheets
If ws.Name <> "Index" And ws.Name <> "Main" Then
'word = ws.Name
lastrow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
For Each w In Split(ws.Name, "+")
word = Trim(w)
For r = ROW_TEXT To UBound(arData)
txt = arData(r, 1)
If InStr(1, txt, word, vbTextCompare) > 0 Then
lastrow = lastrow + 1
wsMain.Rows(r).Copy ws.Cells(lastrow, 1)
arDelete(r) = True
n = n + 1
End If
Next
Next
' update index
wsIndex.Cells(i, 1) = ws.Name
wsIndex.Cells(i, 2) = lastrow - 1
i = i + 1
End If
Next
' delete or highlight rows
' scan upwards
For r = UBound(arDelete) To ROW_TEXT Step -1
If arDelete(r) = True Then
wsMain.Cells(r, COL_TEXT).Interior.Color = vbYellow
'wsMain.Rows(r).Delete 'uncomment to delete
End If
Next
Application.ScreenUpdating = True
MsgBox n & " lines copied", vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
Sub CreateIndex()
Dim ws As Worksheet, bHasIndex As Boolean
For Each ws In Sheets
If ws.Name = "Index" Then bHasIndex = True
Next
' create index
If Not bHasIndex Then
Worksheets.Add(before:=Sheets(1)).Name = "Index"
End If
' format index
With Sheets("Index")
.Cells.Clear
With .Range("A1:B1")
.Value2 = Array("WS Names", "Count")
.Font.Size = 14
.Font.Bold = True
.Font.Color = vbBlue
End With
.Columns("A:B").AutoFit
.Columns("B:B").HorizontalAlignment = xlCenter
End With
End Sub

Excel VBA Debugging

I'm running into a "run time error 1004". I suspect this has something to do with how much data I want my code to process. Currently I am running a 246 column by 30,000 row. What I'm trying to achieve is to consolidate my data into one row item because the current system export the data into individual row as a duplicate for certain data columns. As a result, the data has a ladder/stagger effect where there's duplicate row ID with blank cells in one and data below it.
Example:
Code:
Option Explicit
Sub consolidate()
Const SHEET_NAME = "Archer Search Report"
Const NO_OF_COLS = 101
Dim wb As Workbook, ws As Worksheet
Dim irow As Long, iLastRow As Long, c As Long, count As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets(SHEET_NAME)
iLastRow = ws.Range("A" & Rows.count).End(xlUp).Row
' scan up sheet
For irow = iLastRow - 1 To 2 Step -1
' if same id below
If ws.Cells(irow + 1, 1) = ws.Cells(irow, 1) Then
' scan across
For c = 1 To NO_OF_COLS
' if blank copy from below
If Len(ws.Cells(irow, c)) = 0 Then
ws.Cells(irow, c) = ws.Cells(irow + 1, c)
End If
Next
ws.Rows(irow + 1).Delete
count = count + 1
End If
Next
MsgBox iLastRow - 1 & " rows scanned" & vbCr & _
count & " rows deleted from " & ws.Name, vbInformation
End Sub
I suspect it has to do with the massive amount of data it's running and wanted to see if that is the case. If so, is there an alternative approach? Appreciate the assistance.
Note: I got this awesome code from someone(CDP1802)here and have been using it for years with smaller data set.
Here's a slightly different approach which does not require sorting by id, includes some checking for error values, and does not overwrite any data in the output.
Sub consolidate()
Const SHEET_NAME = "Archer Search Report"
Const NO_OF_COLS = 10 'for example
Dim wb As Workbook, ws As Worksheet, dataIn, dataOut
Dim i As Long, c As Long
Dim dict As Object, id, rwOut As Long, idRow As Long, vIn, vOut, rngData As Range
Set wb = ThisWorkbook
Set ws = wb.Sheets(SHEET_NAME)
Set dict = CreateObject("scripting.dictionary")
Set rngData = ws.Range("A2:A" & ws.Cells(ws.Rows.count, 1).End(xlUp).Row).Resize(, NO_OF_COLS)
dataIn = rngData.Value 'input data as 2D array
ReDim dataOut(1 To UBound(dataIn, 1), 1 To NO_OF_COLS) 'resize "out" to match "in" array size
rwOut = 0 'row counter for "out" array
For i = 1 To UBound(dataIn, 1)
id = dataIn(i, 1) 'id for this "row"
If Not dict.exists(id) Then
'not seen this id before
rwOut = rwOut + 1
dict(id) = rwOut 'add id and row to dictionary
dataOut(rwOut, 1) = id 'add id to "out" array
End If
idRow = dict(id) 'row locator in the "out" array
For c = 2 To NO_OF_COLS
vIn = dataIn(i, c) 'incoming value
vOut = dataOut(idRow, c) 'existing value
'ignore error values, and don't overwrite any existing value in the "out" array
If Not IsError(vIn) Then
If Len(vIn) > 0 And Len(vOut) = 0 Then dataOut(idRow, c) = vIn
End If
Next c
Next i
rngData.Value = dataOut 'replace input data with output array
MsgBox "Got " & rwOut & " unique rows from " & UBound(dataIn, 1)
End Sub

How can I change the direction this script is grouping data?

I have a script that forms arrays within an overarching array based on duplicate values in column A.
manager 1 its own workbook
manager 2
manager 2 these two would be grouped into another workbook and so on.
problem is, these cells in column A are now transposed as headers in row 1.
How would I edit this script to now group this data by the row headers and take the whole column instead of how the script is originally written?
I figure it has something to do with swapping the Last = Data(1,i) or something like that.
Option Explicit
Sub Main()
Dim wb As Workbook
Dim Data, Last, JobFamily
Dim i As Long, j As Long, k As Long, a As Long
Dim Dest As Range
'Refer to the template
Set wb = Workbooks("Book2.xlsx")
'Refer to the destination cell
Set Dest = wb.Sheets("Sheet11").Range("B1")
'Read in all data
With ThisWorkbook.Sheets("Sheet1")
Data = .Range("bj2", .Range("A" & Rows.Count).End(xlUp))
End With
wb.Activate
Application.ScreenUpdating = False
'Process the data
For i = 1 To UBound(Data)
'Manager changes?
If Data(i, 1) <> Last Then
'Skip the first
If i > 1 Then
'Scroll into the view
Dest.Select
'Save a copy
wb.SaveCopyAs ThisWorkbook.Path & Application.PathSeparator & _
ValidFileName(Last & ".xlsx")
End If
'Clear the employees
Dest.Resize(, Columns.Count - Dest.Column).EntireColumn.ClearContents
'Remember this manager
Last = Data(i, 1)
'Start the next round
j = 0
End If
'Write the employee data into the template
a = 0
For k = 1 To UBound(Data, 2)
Dest.Offset(a, j) = Data(i, k)
a = a + 1
Next
'Next column
j = j + 1
Next
End Sub
You called it. All references to "Data(i,1)" must be replaced with "Data(1,i)" to transpose the first column of the range into the first row.

Delete specific rows using range function

I want to delete all rows in excel sheet if specific column value starts with 1.
For example, if range of A1:A having values starts with 1 then I want to delete all those rows using excel vba.
How to get it?
Dim c As Range
Dim SrchRng
Set SrchRng = Sheets("Output").UsedRange
Do
Set c = SrchRng.Find("For Men", LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Delete
Loop While Not c Is Nothing
Here's the required code with comments on how it works. Feed the worksheet and column number to the sub and call it e.g. Delete Rows 2, Sheets("myWorksheet"):
Sub DeleteRows(columnNumber as Integer, ws as WorkSheet)
Dim x as long, lastRow as Long
' get the last used row
lastRow = ws.cells(1000000, columnNumber).end(xlUp).Row
'loop backwards from the last row and delete applicable rows
For x = lastRow to 1 Step -1
' if the cell starts with a number...
If IsNumeric(Left(ws.Cells(x, columnNumber), 1) Then
'Delete it the row if it's equaal to 1
If Left(ws.Cells(x, columnNumber), 1) = 1 Then ws.Rows(x &":"& x).Delete
End If
Next x
End Sub
Dim Value As String
Dim CellName As String
Dim RowNumber As Long
Do While Value <> ""
CellName = "A" + RowNumber
Value = ActiveSheet.Cells(GetRowNumber(CellName), GetColumnNumber(CellName)).Value
If Mid(Value, 1, 1) = "2" Then
ActiveSheet.Range("A" & RowNumber).EntireRow.Delete
End If
RowNumber = RowNumber + 1
Loop
Private Function GetColumnNumber(ByVal CellName As String) As Long
For L = 1 To 26
If Left(CellName, 1) = Chr(L + 64) Then
GetColumnNumber = L
Exit For
End If
Next
End Function
Private Function GetRowNumber(ByVal CellName As String) As Long
GetRowNumber = CLng(Mid(CellName, 2))
End Function
You may be pushing the bounds of what is reasonable to do in Excel vba.
Consider importing the Excel file into Microsoft Access.
Then, you can write 2 Delete Queries and they will run uber fast:
DELETE FROM MyTable WHERE col1 like '2*'
DELETE FROM MyTable WHERE col2 LIKE '*for men*' OR col3 LIKE '*for men*'
After deleting those records, you can export the data to a new Excel file.
Also, you can write an Access Macro to import the Excel File, run the Delete Queries, and Export the data back to Excel.
And you can do all of this without writing a line of VBA Code.
You can try:
Sub delete()
tamano = Range("J2") ' Value into J2
ifrom = 7 ' where you want to delete
'Borramos las celdas
'Delete column A , B and C
For i = ifrom To tamano
Range("A" & i).Value = ""
Range("B" & i).Value = ""
Range("C" & i).Value = ""
Next i
End Sub

Resources