I'm new to VBA. I have this code that works perfectly fine with hundred thousands of data. Any idea how I could keep this code and add any function or code that could skip copying cells that contain "no" and copy the rest of the cells that contains anything.
This code do: Copy cells isnotblank from column C and paste it to column A
Function RefRangeFind( _
ByVal firstRowRange As Range, _
Optional ByVal DisplayMessage As Boolean = False) _
As Range
With firstRowRange.Areas(1).Rows(1)
Dim cell As Range
With .Resize(.Worksheet.Rows.Count - .Row + 1)
Set cell = .Find("*", , xlFormulas, , xlByRows, xlPrevious)
If cell Is Nothing Then
If DisplayMessage Then
MsgBox "No data found in range """ & .Address(0, 0) _
& """ of worksheet """ & .Worksheet.Name & """!", _
vbExclamation
End If
Exit Function
End If
End With
Set RefRangeFind = .Resize(cell.Row - .Row + 1)
End With
End Function
Function IsNoErrorNoBlank( _
Value As Variant) _
As Boolean
If Not IsError(Value) Then
If Len(Value) > 0 Then IsNoErrorNoBlank = True
End If
End Function
Sub lain()
With ThisWorkbook.Sheets("ALL")
Dim rg As Range
Set rg = RefRangeFind(.Range("C2:D2"))
If rg Is Nothing Then Exit Sub
Dim Data() As Variant
Data = rg.Value: Dim r As Long, c As Long
For r = 1 To UBound(Data, 1)
For c = 1 To UBound(Data, 2)
If Not IsNoErrorNoBlank(Data(r, c)) Then Data(r, c) = Empty
Next c
Next r
.Range("A2").Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
End With
End Sub
Include a condition in If
clause to erase cells that contain the word no
.
Sub lain()
With ThisWorkbook.Sheets(1)
Dim rg As Range
Set rg = RefRangeFind(.Range("C2:D2"))
If rg Is Nothing Then Exit Sub
Dim Data() As Variant
Data = rg.Value: Dim r As Long, c As Long
For r = 1 To UBound(Data, 1)
For c = 1 To UBound(Data, 2)
If InStr(1, Data(r, c), "no", vbTextCompare) > 0 Or _
(Not IsNoErrorNoBlank(Data(r, c))) Then Data(r, c) = Empty
Next c
Next r
.Range("A2").Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
End With
End Sub
If you want to delete cells that contain the word no
Sub lain()
With ThisWorkbook.Sheets(1)
Dim rg As Range, noRng As Range
Set rg = RefRangeFind(.Range("C2:D2"))
If rg Is Nothing Then Exit Sub
Dim Data() As Variant
Data = rg.Value: Dim r As Long, c As Long
For r = 1 To UBound(Data, 1)
For c = 1 To UBound(Data, 2)
If InStr(1, Data(r, c), "no", vbTextCompare) > 0 Then
If noRng Is Nothing Then
Set noRng = .Cells(r + 1, c)
Else
Set noRng = Application.Union(noRng, .Cells(r + 1, c))
End If
ElseIf Not IsNoErrorNoBlank(Data(r, c)) Then
Data(r, c) = Empty
End If
Next c
Next r
.Range("A2").Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
If Not noRng Is Nothing Then
noRng.Delete xlShiftUp
End If
End With
End Sub
Question: i mean do not copy cells containing "no". Instead go to the next row and copy if it doesn't contain "no".
Sub lain()
With ThisWorkbook.Sheets(1)
Dim rg As Range
Set rg = RefRangeFind(.Range("C2:D2"))
If rg Is Nothing Then Exit Sub
Dim Data() As Variant
Data = rg.Value
Dim r As Long, c As Long, bFound As Boolean, iR As Long
For r = 1 To UBound(Data, 1)
bFound = False
For c = 1 To UBound(Data, 2)
If Not IsError(Data(r, c)) Then
If InStr(1, Data(r, c), "no", vbTextCompare) > 0 Then
bFound = True
Exit For
End If
End If
Next c
If Not bFound Then
iR = iR + 1
For c = 1 To UBound(Data, 2)
If IsNoErrorNoBlank(Data(r, c)) Then
Data(iR, c) = Data(r, c)
Else
Data(iR, c) = Empty
End If
Next
End If
Next r
.Range("A2").Resize(iR, UBound(Data, 2)).Value = Data
End With
End Sub
Microsoft documentation: