Comparing value of cells from two different sheets - vba

First my code:
Option Explicit
Sub UpdateCandidates()
Application.ScreenUpdating = False
Dim wks As Worksheet, wks2 As Worksheet
Dim Lastrow As String, Lastrow2 As String
Dim Rng As Range, i As Long, Rng2 As Range, i2 As Long
Dim cell As Variant, cell2 As Variant
Set wks = ThisWorkbook.Worksheets("Candidates")
Lastrow = wks.Range("B" & Rows.Count).End(xlUp).Row
If Lastrow > 1 Then
cell = wks.Range("B2:B" & Lastrow).Value
i = 1: Set Rng = Nothing
While i <= Lastrow
For i = i To Lastrow
Set wks2 = ThisWorkbook.Worksheets("Job live")
Lastrow2 = wks2.Range("A" & Rows.Count).End(xlUp).Row
If Lastrow2 > 1 Then
cell2 = wks2.Range("A2:A" & Lastrow2).Value
i2 = 1: Set Rng2 = Nothing
While i2 <= Lastrow2
For i2 = i2 To Lastrow2
If cell = cell2(i2, 1) Then
MsgBox ("found")
End If
Next
Wend
End If
Next
Wend
End If
Application.ScreenUpdating = True
End Sub
This basically works and compares the two columns but at the end it shows an error:
"Subscript out of range"
I don't understand why. I thought it's because of <= Lastrow but fixing to < Lastrow doesn't change anything.
I also would like to copy a value from the first sheet to the second one to a particular cell. And also insert a row below the cell from my second sheet.
I also don't understand why I have to compare cell to cell2(i2,1) and not cell to cell2. If I compare cell to cell2 it says type mismatch. And I have the same error if I enter a second value in my sheets.
What's wrong with my code?

I see your code, and here's a proposal
Option Explicit
Sub CompareDefinedRanges()
Dim rng1, rng2 As Range
Dim found As Boolean
Dim i, j, foundAt As Integer
Set rng1 = Worksheets("Candidates").Range("B2", Worksheets("candidates").Range("B2").End(xlDown).Address)
Set rng2 = Worksheets("Job live").Range("A2", Worksheets("Job Live").Range("A2").End(xlDown).Address)
'show items
For i = 1 To rng1.Rows.Count
found = False
foundAt = 0
For j = 1 To rng2.Rows.Count
If rng1.Item(i) = rng2.Item(j) Then
found = True
foundAt = j
End If
Next j
If found Then
MsgBox rng1.Item(i).Value & " found at " & CStr(foundAt), , "Candidates"
Else
MsgBox rng1.Item(i).Value & " not found", , "Candidates"
End If
Next i
Set rng1 = Nothing
Set rng2 = Nothing
End Sub

Related

Select the same range in multiple workheets

So I need to select the same range in all worksheets except "Sheet1". The range is dinamic based on the value "s1" on the column A. So I want to select what is in column B for the value s1, make it bold, then to count the s1 values in column C.
This is what I have so far
Sub test()
Dim ws As Worksheet
Dim lastrow As Long
Dim xRg As Range, yRg As Range, zRg As Range
Dim cell As Range
Dim C1 As Range
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Sheet1" Then
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For Each xRg In Range("A1:A" & lastrow)
If xRg.Text = "s1" Then
If yRg Is Nothing Then
Set yRg = Range("B" & xRg.Row).Resize(, 1)
k = 1
For Each cell In yRg
yRg.Cells(k, 2) = k
yRg.Cells.Select
k = k + 1
Next cell
Else
Set yRg = Union(yRg, Range("B" & xRg.Row).Resize(, 1))
If Not yRg Is Nothing Then yRg.Select
For Each C1 In yRg
C1.EntireRow.Font.Bold = True
Next C1
End Sub
Try this code:
Option Explicit
Sub test()
Dim ws As Worksheet
Dim xRg As Range, yRg As Range
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Sheet1" Then
ws.Cells.Font.Bold = False ' clear bold formatting for debugging purposes
Set yRg = Nothing
For Each xRg In ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp))
If xRg.Text = "s1" Then
If yRg Is Nothing Then
Set yRg = xRg.Offset(0, 1)
Else
Set yRg = Union(yRg, xRg.Offset(0, 1))
End If
xRg.Offset(0, 2) = yRg.Cells.Count 'set entry number
End If
Next xRg
If Not yRg Is Nothing Then yRg.Font.Bold = True
End If
Next ws
Application.ScreenUpdating = True
End Sub
Before
After
A selection or a range does not extend across multiple sheets; there is a selection per sheet. So you need to work within each sheet.
You had a lot of unclosed loops and conditions. This is my best guess at what you were trying to do:
Sub test()
Dim ws As Worksheet
Dim lastrow As Long
Dim xRg As Range, yRg As Range
Dim cell As Range
Dim s1count As Long
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Sheet1" Then
Set yRg = Nothing
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For Each xRg In Range("A1:A" & lastrow)
If xRg.Text = "s1" Then
If yRg Is Nothing Then
Set yRg = xRg.Offset(0, 1)
Else
Set yRg = Union(yRg, xRg.Offset(0, 1))
End If
End If
Next xRg
If Not yRg Is Nothing Then
s1count = 0
For Each cell In yRg
cell.EntireRow.Font.Bold = True
s1count = s1count + 1
cell.Offset(0, 1) = s1count
Next cell
End If
End If
Next ws
End Sub

How to sum a particular column using it's column names

I have tried to sum a particular column by searching through the column names that are available in a sheet, but it's throwing some error , were i couldn't overcome that error.Can anyone help me out this
Thank you in advance
Dim sh As Worksheet
Dim Fnd As Range
Dim c As Long
Dim lr As Long
Set sh = Sheets("Sheet1")
Set Fnd = sh.Rows(1).Find("Basic", , xlValues, xlWhole)
lr = Fnd.Cells(Fnd.Rows.Count, 1).End(xlUp).Row
If Not Fnd Is Nothing Then
Fnd.Cells(lr + 1, 0).Formula = "=SUM(" & Fnd.Range(Fnd.Cells(2, 0), Fnd.Cells(lr, 0)).Address & ")"
Else
MsgBox "Search Item Not Found!"
Exit Sub
End If
End Sub
This would solve it:
Option Explicit
Sub Test()
Dim RngToSum As Range, StrFind As String, ws As Worksheet, Col As Integer, LastRow As Long
StrFind = "Basic"
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
Col = 0
On Error Resume Next 'Error handler
Col = .Cells.Find(StrFind).Column 'Find the column
On Error GoTo 0
If Not Col = 0 Then 'If the item is found
LastRow = .Cells(.Rows.Count, Col).End(xlUp).Row 'the last row of that column
Set RngToSum = .Range(.Cells(2, Col), .Cells(LastRow, Col)) 'Set the range
.Cells(LastRow + 1, Col) = Application.Sum(RngToSum) 'sum the range on the next available row
Else
MsgBox "Search Item Not Found!"
End If
End With
End Sub

Copy Range into Specific Row/Cell and avoid overwriting the data

Fairly new to VBA Excel. I want to copy and paste a specific cell[B11 and so on) into a specific cell [E9 and so on] on my target sheet when conditions are met (when C column is equal to No). So far I was able to copy and paste the data on my target sheet. Having trouble when I run the command again. I don't want to overwrite my previous data. How can this be done? `
Private Sub CommandButton1_Click()
Dim RowGCnt As Long, CShtRow As Long
Dim LastRow As Long
Dim CellG As Range
'paste the first result to the 9th row
CShtRow = 9
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For RowGCnt = 11 To LastRow
If Range("C" & RowGCnt).Value = "No" Then
MsgBox (CShtRow)
'Review Criteria
Worksheets("SHEET1").Range("B" & RowGCnt).Copy
Worksheets("REPORT").Range("E" & CShtRow).PasteSpecial xlPasteValues
CShtRow = CShtRow + 1
End If
Next RowGCnt
Application.CutCopyMode = False
End Sub
Untested:
Private Sub CommandButton1_Click()
Dim shtSrc As Worksheet '<< source sheet
Dim RowGCnt As Long
Dim LastRow As Long
Dim cDest As Range '<< copy destination
Set shtSrc = Worksheets("SHEET1")
'paste the first result to the first open row
With Worksheets("REPORT")
Set cDest = .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0) '<<EDIT
If cDest.Row < 9 Then Set cDest = .Range("E9")
End With
LastRow = shtSrc.Range("A" & shtSrc.Rows.Count).End(xlUp).Row
For RowGCnt = 11 To LastRow
If shtSrc.Range("C" & RowGCnt).Value = "No" Then
cDest.Value = shtSrc.Range("B" & RowGCnt).Value
Set cDest = cDest.Offset(1, 0)
End If
Next RowGCnt
End Sub
Using Tim Williams code. I got a workaround
Private Sub CommandButton1_Click()
Dim shtSrc As Worksheet '<< source sheet
Dim RowGCnt As Long
Dim LastRow As Long
Dim cDest As Range '<< copy destination
Dim vLastRow As Integer
Set shtSrc = Worksheets("SHEET1")
'paste the first result to the first open row
With Worksheets("REPORT")
Set cDest = .Cells(.Rows.Count, "E").End(xlUp)
If cDest.Row < 9 Then
Set cDest = .Range("E9")
Else
vLastRow = .Cells(.Rows.Count, 5).End(xlUp).Row
Set cDest = .Cells(vLastRow + 1, 5)
End If
End With
LastRow = shtSrc.Range("A" & shtSrc.Rows.Count).End(xlUp).Row
For RowGCnt = 11 To LastRow
If shtSrc.Range("C" & RowGCnt).Value = "No" Then
cDest.Value = shtSrc.Range("B" & RowGCnt).Value
Set cDest = cDest.Offset(1, 0)
End If
Next RowGCnt
End Sub

Copy cells from a specific column to another worksheet based on criteria

I have two worksheets, "Signed" and "April". I want to copy Column "Y" from "Signed" based on certain criteria into column "A" of "April" starting from the next available/blank row. ( so right under the existing data).
My criteria for column Y is that if column L = month of cell "D2" from "April" AND the year of cell "D2" from "ApriL"...( so right now D2 is 4/30/2017).. then copy that cell in the next available row of Col A of "April" and keep adding on.
I've been trying several different things but just am not able to get it..any idea on how I can achieve this?
My code is below:
Set sourceSht = ThisWorkbook.Worksheets("Signed")
Set myRange = sourceSht.Range("Y1", Range("Y" & Rows.Count).End(xlUp))
Set ws2 = Sheets(NewSheet)
DestRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1
For Each rw In myRange.Rows
If rw.Cells(12).Value = "Month(Sheets(ws2).Range("D2"))" Then
myRange.Value.Copy Destinations:=Sheets(ws2).Range("A" & DestRow)
End If
Something like this should work for you:
Sub tgr()
Dim wb As Workbook
Dim wsData As Worksheet
Dim wsDest As Worksheet
Dim aData As Variant
Dim aResults() As Variant
Dim dtCheck As Date
Dim lCount As Long
Dim lResultIndex As Long
Dim i As Long
Set wb = ActiveWorkbook
Set wsData = wb.Sheets("Signed") 'This is your source sheet
Set wsDest = wb.Sheets("April") 'This is your destination sheet
dtCheck = wsDest.Range("D2").Value2 'This is the date you want to compare against
With wsData.Range("L1:Y" & wsData.Cells(wsData.Rows.Count, "L").End(xlUp).Row)
lCount = WorksheetFunction.CountIfs(.Resize(, 1), ">=" & DateSerial(Year(dtCheck), Month(dtCheck), 1), .Resize(, 1), "<" & DateSerial(Year(dtCheck), Month(dtCheck) + 1, 1))
If lCount = 0 Then
MsgBox "No matches found for [" & Format(dtCheck, "mmmm yyyy") & "] in column L of " & wsData.Name & Chr(10) & "Exiting Macro"
Exit Sub
Else
ReDim aResults(1 To lCount, 1 To 1)
aData = .Value
End If
End With
For i = 1 To UBound(aData, 1)
If IsDate(aData(i, 1)) Then
If Year(aData(i, 1)) = Year(dtCheck) And Month(aData(i, 1)) = Month(dtCheck) Then
lResultIndex = lResultIndex + 1
aResults(lResultIndex, 1) = aData(i, UBound(aData, 2))
End If
End If
Next i
wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Resize(lCount).Value = aResults
End Sub
Alternate method using AutoFilter instead of iterating over an array:
Sub tgrFilter()
Dim wb As Workbook
Dim wsData As Worksheet
Dim wsDest As Worksheet
Dim dtCheck As Date
Set wb = ActiveWorkbook
Set wsData = wb.Sheets("Signed") 'This is your source sheet
Set wsDest = wb.Sheets("April") 'This is your destination sheet
dtCheck = wsDest.Range("D2").Value2 'This is the date you want to compare against
With wsData.Range("L1:Y" & wsData.Cells(wsData.Rows.Count, "L").End(xlUp).Row)
.AutoFilter 1, , xlFilterValues, Array(1, Format(WorksheetFunction.EoMonth(dtCheck, 0), "m/d/yyyy"))
Intersect(.Cells, .Parent.Columns("Y")).Offset(1).Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
.AutoFilter
End With
End Sub
Here's a generic script which you can easily modify to handle almost ANY criteria, as needed.
Sub Copy_If_Criteria_Met()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Sheet1").Range("A1:A" & I)
On Error Resume Next
Application.ScreenUpdating = False
For Each xCell In xRg
If CStr(xCell.Value) = "X" Then
xCell.EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
xCell.EntireRow.Delete
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub

Excel VBA - Check Values in Sheet1 Against Sheet2, then Copy Notes If Matching

I have two sheets. I want to check the value in one column against the value in the same column in the second sheet. If they match, then I want to migrate the string data from the Notes column to the new sheet. (essentially I'm seeing if last week's ticket numbers are still valid this week, and carrying over the notes from last week).
I am trying to do this with the following code (using columns Z for the data, BE for the notes):
Sub Main()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Dim partNo2 As Range
Dim partNo1 As Range
Dim partNo3 As Range
For Each partNo2 In ws1.Range("Z1:Z" & ws1.Range("Z" & Rows.Count).End(xlUp).Row)
For Each partNo1 In ws2.Range("Z1:Z" & ws2.Range("Z" & Rows.Count).End(xlUp).Row)
For Each partNo3 In ws1.Range("BE1:BE" & ws2.Range("BE" & Rows.Count).End(xlUp).Row)
If StrComp(Trim(partNo2), Trim(partNo1), vbTextCompare) = 0 Then
ws2.Range("BE" & partNo1.Row) = partNo3
End If
Next
Next
Next
'now if no match was found then put NO MATCH in cell
For Each partNo1 In ws2.Range("E1:F" & ws2.Range("A" & Rows.Count).End(xlUp).Row)
If IsEmpty(partNo1) Then partNo1 = ""
Next
End Sub
Untested:
Sub Main()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range, rng2 As Range
Dim c As Range, f As Range
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Set rng1 = ws1.Range("Z1:Z" & ws1.Range("Z" & Rows.Count).End(xlUp).Row)
Set rng2 = ws2.Range("Z1:Z" & ws2.Range("Z" & Rows.Count).End(xlUp).Row)
For Each c In rng1.Cells
Set f = rng2.Find(c.Value, , xlValues, xlWhole)
If Not f Is Nothing Then
f.EntireRow.Cells(, "BE").Value = c.EntireRow.Cells(, "BE").Value
End If
Next c
'now if no match was found then put NO MATCH in cell
For Each c In ws2.Range("E1:F" & ws2.Range("A" & Rows.Count).End(xlUp).Row)
If Len(c.Value) = 0 Then c.Value = "NO MATCH"
Next
End Sub
This accomplishes the same result (maybe with the exception of the columns E & F at the bottom with NO MATCH). It's just a different way of going about it. Instead of using ranges, I'm just looking at each cell and comparing it directly.
TESTED:
Sub NoteMatch()
Dim lastRow1 As Long
Dim lastRow2 As Long
Dim tempVal As String
lastRow1 = Sheets("Sheet1").Range("Z" & Rows.Count).End(xlUp).row
lastRow2 = Sheets("Sheet2").Range("Z" & Rows.Count).End(xlUp).row
For sRow = 2 To lastRow1
tempVal = Sheets("Sheet1").Cells(sRow, "Z").Text
For tRow = 2 To lastRow2
If Sheets("Sheet2").Cells(tRow, "Z") = tempVal Then
Sheets("Sheet2").Cells(tRow, "BE") = Sheets("Sheet1").Cells(sRow, "BE")
End If
Next tRow
Next sRow
Dim match As Boolean
'now if no match was found, then put NO MATCH in cell
For lRow = 2 To lastRow2
match = False
tempVal = Sheets("Sheet2").Cells(lRow, "Z").Text
For sRow = 2 To lastRow1
If Sheets("Sheet1").Cells(sRow, "Z") = tempVal Then
match = True
End If
Next sRow
If match = False Then
Sheets("Sheet2").Cells(lRow, "BE") = "NO MATCH"
End If
Next lRow
End Sub