I am working with an excel which has about 500000 rows. I have one sheet called "B" where is all the info and I only need the rows where the column Y contains text, not de #N/A from the LOOKUP. I have to copy the rows with info, to another sheet called "A". I used this code for the same process
On Error Resume Next
Columns("Y").SpecialCells(xlFormulas, xlErrors).EntireRow.Delete
On Error GoTo 0
But in this case, there are many rows so it takes 5 minutes(not worthy)
I only have 3000 rows with non NA, so I thought it will be easier to filter them and copy to "A" the entire row(the column A from the row in "B" it's not necessary, and the destination sheet "A" the column A has to be empty). I don't know how to do it, i'm new in this language, thank you
Sheet B; the column Y with the header SKU contains the not found and the found ones ex:SKU1233444
I have to copy from B except headers and column A, all the rows with SKU found and paste them into Sheet A leaving its headers and the column A empty because it's formulated
CodePudding user response：
Arrays work faster than deleting rows one by one in VBA
Arrays need to be transposed / flipped before they're pasted into a worksheet
I ran the code below and it works.
I assumed that we're only working from column B as your attached photo above seems to suggest
Option Explicit ensures that we declare all variables we use.
$ is short hand for string; % for integer; & for long
Option Explicit
Private Sub Test()
Dim sChar$, sRange$, sRange2$
Dim iCol%, iLastUsedCol%
Dim iLastUsedRow&, iRow&
Dim r As Range
Dim aCleaned As Variant, aData As Variant
Dim WS As Worksheet, WS2 As Worksheet
Set WS = ThisWorkbook.Sheets("A")
Set WS2 = ThisWorkbook.Sheets("B")
With WS
'furthest column to right on a worksheet
sChar = ColumnChars2(Columns.Count)
'last used header column on this sheet
iLastUsedCol = .Range(sChar & 1).End(xlToLeft).Column
'last used row of data on this sheet
iLastUsedRow = .Range("A" & Rows.Count - 1).End(xlUp).Row
'cells containing data
sRange = "B2:" & ColumnChars2(iLastUsedCol) & iLastUsedRow
'transferring data to array
aData = .Range(sRange)
End With
'temporary store for row of data
ReDim aParam(iLastUsedCol - 2)
'cleaned data
ReDim aCleaned(iLastUsedCol - 2, 0)
'setting first entry of cleaned data to blank initially - needed for AddEntry subroutine called below
aCleaned(0, 0) = ""
For iRow = 1 To UBound(aData)
'if Y column cell for this row does not contain error
If Not IsError(aData(iRow, 24)) Then
'save entire row temporarily
For iCol = 0 To UBound(aParam)
aParam(iCol) = aData(iRow, iCol 1)
Next
'transfer saved row to cleaned data array
Call AddEntry(aCleaned, aParam)
End If
Next
With WS2
iLastUsedCol = .Range(sChar & 1).End(xlToLeft).Column
iLastUsedRow = .Range("B" & Rows.Count - 1).End(xlUp).Row
'if data in B sheet
If iLastUsedRow > 1 Then
sRange2 = "B2:" & ColumnChars2(iLastUsedCol) & iLastUsedRow
'empty
.Range(sRange2).ClearContents
End If
Set r = .Range("B2")
'copy cleaned data to sheet B
r.Resize(UBound(aCleaned, 2) 1, UBound(aCleaned, 1) 1).Value = my_2D_Transpose(aCleaned)
End With
End Sub
The first subroutine called by the test routine above:
Public Function ColumnChars2(iCol As Variant) As String
On Error GoTo Err_Handler
'
' calculates character form of column number
'
Dim iPrePrefix As Integer, iPrefix As Integer, iSuffix As Integer
iSuffix = iCol
iPrefix = 0
Do Until iSuffix < 27
iSuffix = iSuffix - 26
iPrefix = iPrefix 1
Loop
iPrePrefix = 0
Do Until iPrefix < 27
iPrefix = iPrefix - 26
iPrePrefix = iPrePrefix 1
Loop
ColumnChars2 = IIf(iPrePrefix = 0, "", Chr(64 iPrePrefix)) & IIf(iPrefix = 0, "", Chr(64 iPrefix)) & Chr(64 iSuffix)
Exit Function
Exit_Label:
On Error Resume Next
Application.Cursor = xlDefault
Application.ScreenUpdating = True
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Exit Function
Err_Handler:
MsgBox Err.Description, vbCritical, "ColumnChars2"
Resume Exit_Label
End Function
The second subroutine called by the test routine above:
Public Sub AddEntry(aList As Variant, aEntry As Variant)
'
' build array for later copy onto sheet
'
Dim i%
Dim aEntry2 As Variant
If VarType(aEntry) = vbString Then
aEntry2 = Array(aEntry)
Else
aEntry2 = aEntry
End If
If aList(0, 0) <> "" Then
ReDim Preserve aList(0 To UBound(aEntry2), 0 To UBound(aList, 2) 1)
End If
For i = 0 To UBound(aEntry2)
aList(i, UBound(aList, 2)) = aEntry2(i)
Next
End Sub
The third subroutine called by the test routine above:
Function my_2D_Transpose(arr As Variant)
On Error GoTo Err_Handler
'works better than delivered Application.Transpose function
Dim a&, b&, tmp As Variant
ReDim tmp(LBound(arr, 2) To UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1))
For a = LBound(arr, 1) To UBound(arr, 1)
For b = LBound(arr, 2) To UBound(arr, 2)
tmp(b, a) = arr(a, b)
Next b
Next a
my_2D_Transpose = tmp
Exit Function
Exit_Label:
On Error Resume Next
Application.Cursor = xlDefault
Application.ScreenUpdating = True
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Exit Function
Err_Handler:
MsgBox Err.Description, vbCritical, "my_2D_Transpose"
Resume Exit_Label
End Function
CodePudding user response：
Copy Criteria Rows
Option Explicit
Sub CopyNoErrors()
' Define constants.
' Source
Const sName As String = "B"
Const CritColumnString As String = "Y"
' Destination
Const dName As String = "A"
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source worksheet ('sws').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range
Dim rCount As Long
Dim cCount As Long
' Reference the source range ('srg') excluding the first column
' and the headers.
With sws.Range("A1").CurrentRegion
rCount = .Rows.Count - 1
cCount = .Columns.Count - 1
Set srg = .Resize(rCount, cCount).Offset(1, 1)
End With
' Determine the criteria column ('CritColumn') which has to be reduced
' by one due to the shifting of the source range
' which is starting in column 'B'.
Dim CritColumn As Long
CritColumn = sws.Columns(CritColumnString).Column - 1
' Write the values from the source range to a 2D one-based array ('Data').
Dim Data() As Variant: Data = srg.Value
Dim sr As Long, sc As Long, dr As Long
' Write the rows, not containing the error value in the criteria column,
' to the top of the array.
For sr = 1 To rCount
If Not IsError(Data(sr, CritColumn)) Then
dr = dr 1
For sc = 1 To cCount
Data(dr, sc) = Data(sr, sc)
Next sc
End If
Next sr
' Reference the destination worksheet ('dws').
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
' Reference the destination range ('drg'), a range with the same address
' as the source range.
Dim drg As Range: Set drg = dws.Range(srg.Address)
With drg
' Write the values from the top of the array to the destination range.
.Resize(dr).Value = Data
' Clear below.
.Resize(dws.Rows.Count - .Row - dr 1).Offset(dr).ClearContents
End With
' Inform.
MsgBox "Data copied.", vbInformation
End Sub