VBA Checking if a Value Exists in Column - excel

I'm writing some VBA to check if a value exists in a column.
lRowStatic = Worksheets("GLMapping_Static").Cells(Rows.Count, 1).End(xlUp).Row
lRow = Worksheets("GLMapping").Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lRow
If IsError(Application.Match(Worksheets("GLMapping").Cells(i, 1).Value, Worksheets("GLMapping_Static").Range(Cells(1, 1), Cells(lRowStatic, 1)), 0)) Then
MsgBox "Its not in the range"
Else
MsgBox "Its in the range"
End If
Next i
I'm confused because this code appears to work well if the "GLMapping_Static" worksheet is currently activated. If the "GLMapping" worksheet is currently activated, then I get a 1004 error.
Any idea what is causing this? I assumed there was a cell reference that didn't include a worksheet name, but I'm not seeing one.
Thanks

Qualifying Objects
The critical part is the expression
Worksheets("GLMapping_Static").Range(Cells(1, 1), Cells(lRowStatic, 1))
where Cells are not qualified so when you choose a different worksheet than GLMapping_Static, Cells will refer to the wrong worksheet resulting in a run-time error.
The first example is illustrating how to fully qualify objects (wb-ws-rg). To simplify, one could say that .Range, .Cells, .Rows, and .Columns belong to a worksheet (object), each .Worksheets belongs to a workbook (object), and each .Workbooks belongs to the Application (object).
The other examples are just showing the benefits of using variables and some possible improvements on other accounts.
The Code
Option Explicit
Sub Humongous()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim lRowStatic As Long
lRowStatic = wb.Worksheets("GLMapping_Static") _
.Cells(wb.Worksheets("GLMapping_Static").Rows.Count, 1).End(xlUp).Row
Dim lRow As Long
lRow = wb.Worksheets("GLMapping") _
.Cells(wb.Worksheets("GLMapping").Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = 1 To lRow
If IsError(Application.Match(wb.Worksheets("GLMapping").Cells(i, 1) _
.Value, wb.Worksheets("GLMapping_Static") _
.Range(wb.Worksheets("GLMapping_Static") _
.Cells(1, 1), wb.Worksheets("GLMapping_Static") _
.Cells(lRowStatic, 1)), 0)) Then
MsgBox "Its not in the range"
Else
MsgBox "Its in the range"
End If
Next i
End Sub
Sub Sheeted()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets("GLMapping_Static")
Dim sLast As Long: sLast = sws.Cells(sws.Rows.Count, 1).End(xlUp).Row
Dim srg As Range: Set srg = sws.Range(sws.Cells(1, 1), sws.Cells(sLast, 1))
Dim dws As Worksheet: Set dws = wb.Worksheets("GLMapping")
Dim dLast As Long: dLast = dws.Cells(dws.Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = 1 To dLast
If IsError(Application.Match(dws.Cells(i, 1).Value, srg, 0)) Then
MsgBox "Its not in the range"
Else
MsgBox "Its in the range"
End If
Next i
End Sub
Sub Ranged()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim srg As Range
Dim sLast As Long
With wb.Worksheets("GLMapping_Static")
sLast = .Cells(.Rows.Count, 1).End(xlUp).Row
Set srg = .Range(.Cells(1, 1), .Cells(sLast, 1))
End With
Dim drg As Range
Dim dLast As Long
With wb.Worksheets("GLMapping")
dLast = .Cells(.Rows.Count, 1).End(xlUp).Row
Set drg = .Range(.Cells(1, 1), .Cells(dLast, 1))
End With
Dim dCell As Range
For Each dCell In drg.Cells
If IsNumeric(Application.Match(dCell, srg, 0)) Then
MsgBox "Its in the range"
Else
MsgBox "Its not in the range"
End If
Next i
End Sub

You can do something like this.
Sub TryMe()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws1 = Sheets("GLMapping_Static")
Set ws2 = Sheets("GLMapping")
wb.Activate
ws1.Select
lRowStatic = ws1.Cells(Rows.Count, 1).End(xlUp).Row
lRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lRow
If IsError(Application.Match(ws2.Cells(i, 1).Value, ws1.Range(Cells(1, 1), Cells(lRowStatic, 1)), 0)) Then
MsgBox "Its not in the range"
Else
MsgBox "Its in the range"
End If
Next i
End Sub

Related

Pasting issues using VBA

wish you all the best.
I am making a code using VBA to find and detect errors from one sheet and paste the values from column A and B from the row of the error to the destination sheet.
my code is mostly working my issue is the content that is pasting which is the error cell and the next one to the right instead of the values from A and B (example: imagine macro is running all values in column K and there is an error in K85, it is pasting K85 and L85, instead of A85 and B85)
Sub Copy_NA_Values()
Dim rng As Range
Dim firstBlank As Range
Dim shtSource As Worksheet
Dim shtDestination As Worksheet
Set shtSource = ThisWorkbook.Sheets("JE Royalty detail") 'Change to the name of the source sheet
Set shtDestination = ThisWorkbook.Sheets("DB") 'Change to the name of the destination sheet
Set rng = shtSource.Range("F:F").SpecialCells(xlCellTypeFormulas, xlErrors)
For Each cell In rng
If IsError(Range("F:F")) = False Then
Set firstBlank = shtDestination.Range("K" & Rows.Count).End(xlUp).Offset(1, 0)
cell.Resize(1, 2).Copy firstBlank
End If
Next cell
End Sub
How can I make it so it will paste the correct cells i have tried to use paste special but I might've used it wrongly but I had errors, all help apreciated.
Have a good one.
it is pasting K85 and L85, instead of A85 and B85
Try replacing:
cell.Resize(1, 2).Copy firstBlank
with
shtSource.Range("A" & cell.Row & ":B" & cell.Row).Copy firstBlank
To paste only values, do this instead:
shtSource.Range("A" & cell.Row & ":B" & cell.Row).Copy
firstBlank.PasteSpecial (xlPasteValues)
Copy Values When Matching Error Values
Option Explicit
Sub BackupErrorValues()
Const SRC_NAME As String = "JE Royalty detail"
Const SRC_ERROR_RANGE As String = "F:F"
Const SRC_COPY_RANGE As String = "A:B"
Const DST_NAME As String = "DB"
Const DST_FIRST_CELL As String = "A2"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
Dim srg As Range
On Error Resume Next ' to prevent error if no error values
Set srg = Intersect(sws.UsedRange, sws.Columns(SRC_ERROR_RANGE)) _
.SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0
If srg Is Nothing Then
MsgBox "No cells with error values found.", vbExclamation
Exit Sub
End If
Set srg = Intersect(srg.EntireRow, sws.Range(SRC_COPY_RANGE))
Dim cCount As Long: cCount = srg.Columns.Count
Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
If dws.FilterMode Then dws.ShowAllData ' prevent failure of 'Find' method
Dim dCell As Range
With dws.UsedRange
Set dCell = .Find("*", , xlFormulas, , xlByRows, xlPrevious)
End With
If dCell Is Nothing Then
Set dCell = dws.Range(DST_FIRST_CELL)
Else
Set dCell = dws.Cells(dCell.Row + 1, dws.Range(DST_FIRST_CELL).Column)
End If
Dim drrg As Range: Set drrg = dCell.Resize(, cCount)
Dim sarg As Range, srCount As Long
For Each sarg In srg.Areas
srCount = sarg.Rows.Count
drrg.Resize(srCount).Value = sarg.Value
Set drrg = drrg.Offset(srCount)
Next sarg
MsgBox "Error rows backed up.", vbInformation
End Sub

I can't compare the Dates on VBA

I'm trying to compare the dates that I choose. I mean I'm trying to take the some items which has a date earlier. So I wrote this on VBA. But I noticed that when I run this code the output was the same as input. So it tries to find the earlier items but it couldn't compare so all items are copied.
Private Sub Macro1()
a = Worksheets("SVS").Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To a
If Worksheets("SVS").Cells(i, 22).Value < CDate("28/02/2023") Then
Worksheets("SVS").Rows(i).Copy
Worksheets("Summary").Activate
b = Worksheets("Summary").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Summary").Cells(b + 1, 1).Select
ActiveSheet.Paste
Worksheets("SVS").Activate
End If
Next i
Application.CutCopyMode = False
ThisWorkbook.Worksheets("SVS").Cells(1, 1).Select
End Sub
What is missing in the code? I wanna learn.
Check you have a valid date to compare with.
Option Explicit
Private Sub Macro1()
Dim wb As Workbook, ws As Worksheet, v
Dim lastrow As Long, i As Long, b As Long, n As Long
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Summary")
b = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
With wb.Sheets("SVS")
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 3 To lastrow
v = .Cells(i, 22) ' col V
If IsDate(v) Then
If CDbl(v) < DateSerial(2023, 2, 28) Then
b = b + 1
.Rows(i).Copy ws.Cells(b, 1)
n = n + 1
End If
End If
Next i
End With
MsgBox n & " rows copied to Summary", vbInformation, lastrow - 2 & " rows checked"
End Sub
Append If Earlier Date
Option Explicit
Sub AppendEarlierDate()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Sheets("SVS")
Dim srg As Range
Set srg = sws.Range("V3", sws.Cells(sws.Rows.Count, "V").End(xlUp))
Dim surg As Range, sCell As Range, sValue
For Each sCell In srg.Cells
sValue = sCell.Value
If IsDate(sValue) Then
If sValue < DateSerial(2023, 2, 28) Then
If surg Is Nothing Then
Set surg = sCell
Else
Set surg = Union(surg, sCell)
End If
End If
End If
Next sCell
If surg Is Nothing Then Exit Sub
Dim dws As Worksheet: Set dws = wb.Sheets("Summary")
If dws.FilterMode Then dws.ShowAllData
Dim dlCell As Range, dfCell As Range
Set dlCell = dws.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If dlCell Is Nothing Then
Set dfCell = dws.Range("A1")
Else
Set dfCell = dws.Cells(dlCell.Row + 1, "A")
End If
surg.EntireRow.Copy dfCell
End Sub

Loop a Macro Through all Sheets

I want to loop this macro through all sheets. The macro current works on just one sheet but when I try to add a For Next loop it says the variable is not defined. Basically, I want it to find the text "Total Capital" and delete everything below it for all but two sheets in the workbook. Thank you in advance. This is what I have currently.
Sub DeleteBelowCap()
Dim ws As Worksheet
For Each ws In Worksheets
Dim lngFirstRow As Long, lngLastRow As Long
Dim lngCount As Long
Dim fRg As Range
Set fRg = Cells.Find(what:="Total Capital", lookat:=xlWhole)
lngFirstRow = fRg.Row + 1
lngLastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
For lngCount = lngLastRow To lngFirstRow Step -1
Rows(lngCount).EntireRow.Delete
Next lngCount
Set fRg = Nothing
Next
End Sub
You must be careful since you are looping worksheets NOT to use references like ActiveSheet in your code, or unqualified range references. We see this in two places in your code:
lngLastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
and
Set fRg = Cells.Find(what:="Total Capital", lookat:=xlWhole)
Both of these spell trouble - you will be working on the activesheet in both cases, I think. Or in the latter case, possibly on the worksheet module the code is in (if it is in a worksheet module and not a standard code module).
So, fixes in place:
Sub DeleteBelowCap()
Dim lngFirstRow As Long
Dim lngLastRow As Long
Dim lngCount As Long
Dim fRg As Range
Dim ws As Worksheet
For Each ws In Worksheets
Set fRg = ws.Cells.Find(What:="Total Capital", LookAt:=xlWhole)
If Not fRg Is Nothing Then
lngFirstRow = fRg.Row + 1
lngLastRow = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
ws.Range(ws.Cells(lngFirstRow, 1), ws.Cells(lngLastRow, 1)).EntireRow.Delete
End If
Set fRg = Nothing
Next
End Sub
I'm not a fan of deleting rows, especially row by row. So if your goal is just to clear everything below the found cell, then using a clear method is simple without any extra logic (all the way to the bottom):
Sub DeleteBelowCap2()
Dim fRg As Range
Dim ws As Worksheet
For Each ws In Worksheets
Set fRg = ws.Cells.Find(What:="Total Capital", LookAt:=xlWhole)
If Not fRg Is Nothing Then
ws.Range(ws.Cells(fRg.Row + 1, 1), ws.Cells(Rows.Count, 1)).EntireRow.Clear
End If
Set fRg = Nothing
Next
End Sub
Clear Below the First Found Cell
Option Explicit
Sub ClearBelowCap()
Const SearchString As String = "Total Capital"
Const ExceptionsList As String = "Sheet1,Sheet2"
Dim Exceptions() As String: Exceptions = Split(ExceptionsList, ",")
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet
For Each ws In wb.Worksheets
If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
ClearBelowFirstFoundCell ws, SearchString
End If
Next ws
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: In a worksheet ('ws'), clears the cells in the rows
' that are below the row of the top-most cell
' whose contents are equal to a string ('SearchString').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ClearBelowFirstFoundCell( _
ByVal ws As Worksheet, _
ByVal SearchString As String)
If ws.AutoFilterMode Then ws.AutoFilterMode = False
With ws.UsedRange
Dim lCell As Range: Set lCell = .Cells(.Rows.Count, .Columns.Count)
Dim fCell As Range
Set fCell = .Find(SearchString, lCell, xlFormulas, xlWhole)
If fCell Is Nothing Then Exit Sub
Dim fRow As Long: fRow = fCell.Row
Dim lRow As Long: lRow = lCell.Row
If lRow = fRow Then Exit Sub
.Resize(lRow - fRow).Offset(fRow - .Row + 1).Clear ' .Delete xlShiftUp
End With
End Sub

Copy and paste nonblank cells from sheet1 to sheet2

I'm trying to copy and paste nonblank cells from sheet1 to sheet2.
I'm getting application/object error.
Public Sub CopyRows()
Sheets("Sheet1").Select
FinalRow = Cells(Rows.Count, 1).End(xlDown).Row
For x = 4 To FinalRow
ThisValue = Cells(x, 1).Value
NextRow = Cells(Rows.Count, 1).End(xlDown).Row
If Not IsEmpty(ThisValue) Then
Cells(x, 1).Resize(1, 6).Copy
Sheets(2).Select
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets(1).Select
End If
Next x
End Sub
Copy Rows
Option Explicit
Sub CopyRows()
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
If slRow < 4 Then Exit Sub ' no data
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet2")
Dim dCell As Range: Set dCell = dws.Cells(dws.Rows.Count, "A").End(xlUp)
Application.ScreenUpdating = False
Dim sCell As Range
Dim sr As Long
' Loop and copy.
For sr = 4 To slRow
Set sCell = sws.Cells(sr, "A")
If Not IsEmpty(sCell) Then
Set dCell = dCell.Offset(1)
sCell.Resize(, 6).Copy dCell
End If
Next sr
Application.ScreenUpdating = True
' Inform.
MsgBox "Rows copied.", vbInformation
End Sub
There are multiple problems in your original code. As cybernetic.nomad already pointed out, avoid using Select whenever possible. You also set your NextRow variable to always be the last row in the worksheet instead of the next available row in your destination sheet. Additionally, because of your use of .Select, you have ambiguous Cells calls.
Here is an alternate method using AutoFilter because, for this task, you can take advantage of filtering to only get populated cells without having to perform a loop:
Sub CopyRows()
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim wsSrc As Worksheet: Set wsSrc = wb.Worksheets("Sheet1")
Dim wsDst As Worksheet: Set wsDst = wb.Worksheets("Sheet2")
Dim rData As Range: Set rData = wsSrc.Range("A3", wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp))
If rData.Rows.Count < 2 Then Exit Sub 'No data
With rData
.AutoFilter 1, "<>"
.Offset(1).Resize(, 6).Copy wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Offset(1)
.AutoFilter
End With
End Sub

Copy data from multiple sheet and paste into 1 sheet

I am trying to copy data from multiple sheets and paste it into Sheet1. The result paste it into Sheet1 but the same row each time and not the next row of previous copied data. Here is my code. Any help is really appreciate. Thank you!
Sub LoopCopySheetsData()
Dim i As Integer
Dim wb As Workbook
Dim totalWS As Long
Set wb = ActiveWorkbook
'totalWS = wb.Sheets.Count
totalWS = 4
For i = 2 To totalWS 'Start of the VBA loop
If i < totalWS + 1 Then
Sheets(i).Select
With wb.Sheets(i)
Set findHeadRow = .Range("A:A").Find(What:="Data", LookIn:=xlValues)
End With
headRow = findHeadRow.Row
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Sheets(i).Range("A" & headRow + 1 & ":A" & lastRow).Copy
Range("A1").Activate
With wb.Sheets("Sheet1")
lastRowMaster = Cells(Rows.Count, "D").End(xlUp).Row
Sheets("Sheet1").Range("D" & lastRowMaster + 1).PasteSpecial xlPasteValues
End With
End If
Next i
End Sub
Copy Columns From Multiple Worksheets
If the header cell (Data) contains a formula, you will have to use xlValues instead of xlFormulas (first occurrence).
Adjust the values in the constants section.
Option Explicit
Sub LoopCopySheetsData()
' Source
Const sCol As String = "A"
Const sHeader As String = "Data"
' Destination
Const dName As String = "Sheet1"
Const dCol As String = "D"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range
Set dfCell = dws.Cells(dws.Rows.Count, dCol).End(xlUp).Offset(1)
Dim sws As Worksheet
Dim srg As Range ' Range
Dim shCell As Range ' Header Cell
Dim slCell As Range ' Last Cell
Dim rCount As Long ' Source/Destination Rows Count
For Each sws In wb.Worksheets
If StrComp(sws.Name, dName, vbTextCompare) <> 0 Then ' exclude 'dws'
' Find header cell and last cell.
With sws.Columns(sCol)
Set shCell = _
.Find(sHeader, .Cells(.Cells.Count), xlFormulas, xlWhole)
Set slCell = .Find("*", , xlFormulas, , , xlPrevious)
End With
If Not shCell Is Nothing Then
If Not slCell Is Nothing Then
rCount = slCell.Row - shCell.Row ' without header
If rCount > 0 Then
Set srg = shCell.Offset(1).Resize(rCount)
dfCell.Resize(rCount).Value = srg.Value ' copy
Set dfCell = dfCell.Offset(rCount) ' next
End If
End If
End If
End If
Next sws
MsgBox "Done.", vbInformation
End Sub
Please heed this post: How to avoid using Select in Excel VBA. As second answer mentions, avoid any use of ActiveWorkbook, Activate, and Select for efficiency, maintenance, and readability.
Instead, explicitly qualify all Workbook, Worksheet, Cells, Range, and other objects. In fact, consider range assignment and avoid the need of copy and paste:
Sub LoopCopySheetsData()
Dim i As Integer, totalWS As Integer
Dim headRow As Long, lastRow As Long, headRowMaster As Long, lastRowMaster As Long
'totalWS = ThisWorkbook.Sheets.Count
totalWS = 4
For i = 2 To totalWS
If i < (totalWS + 1) Then
With ThisWorkbook.Sheets(i)
headRow = .Range("A:A").Find(What:="Data", LookIn:=xlValues).Row
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With ThisWorkbook.Sheets("Sheet1")
headRowMaster = .Cells(.Rows.Count, "D").End(xlUp).Row
lastRowMaster = headRowMaster + (lastRow - headRow)
' ASSIGN VALUES BY RANGE
.Range("D" & headRowMaster + 1 & ":D" & lastRowMaster).Value = _
ThisWorkbook.Sheets(i).Range("A" & headRow + 1 & ":A" & lastRow).Value
End With
End If
Next i
End Sub

Resources