I would like to get rid of the sht2.Select and sht2.Range("B2").Select in the code below. Is there a way to do this?
Sub Remaining()
Dim sht2 As Worksheet
Dim cell As Range
Set sht2 = ThisWorkbook.Worksheets("Sheet2")
sht2.Select
sht2.Range("B2").Select
With sht2
For Each cell In .Range("B2", Cells(Rows.Count, "B").End(xlUp))
If .Range("A:A").Find(What:=cell.Value2, LookAt:=xlWhole) Is Nothing Then
Intersect(.UsedRange, cell.EntireRow).Offset(, 1).Copy Sheets("Sheet1").Cells(Rows.Count, "L").End(xlUp).Offset(1)
cell.Interior.Color = vbYellow
End If
Next cell
End With
End Sub
Sub Remaining()
Dim sht2 As Worksheet
Dim cell As Range
Set sht2 = ThisWorkbook.Worksheets("Sheet2")
With sht2
'A few fixes in the following line to make sure everything
' is referencing the correct sheet
For Each cell In .Range(.Range("B2"), .Cells(.Rows.Count, "B").End(xlUp))
If .Range("A:A").Find(What:=cell.Value2, LookAt:=xlWhole) Is Nothing Then
Intersect(.UsedRange, cell.EntireRow).Offset(, 1).Copy _
Sheets("Sheet1").Cells(Rows.Count, "L").End(xlUp).Offset(1)
cell.Interior.Color = vbYellow
End If
Next cell
End With
End Sub
Related
I have a workbook with multiple sheets (Sheet 1, 2...etc) and a "Master" Sheet. I need to select a range from columns A:C until it meets a row with the value (tva) (including those rows). I want to compare that range from Master to the other sheets, and highlight the differences.
Sample image For example Master sheet has in A3 value "m".
This is what I have so far. I'm pretty new at this so any advice is appreciated :)
Sub comp()
Dim ws As Worksheet
Dim rngCell As Range
For Each ws In ThisWorkbook.Worksheets
ws.Activate
rngCell = Columns("A:C").Resize(Columns("A:C").Find(What:="tva", After:=Range("A1"), LookIn:=xlValues, SearchDirection:=xlPrevious).Row)
rngCell.Select
For Each rngCell In ws.Range
If Not rngCell = Worksheets("Master").Cells(rngCell.Row, rngCell.Column) Then
rngCell.Interior.Color = vbYellow
End If
Next ws
End Sub
You can try following code, although it is did not cover other column, but small adjustment only need to check until column C (col 3):
Sub comp()
Dim ws As Worksheet
Dim valuerow As Long, irow As Long
For Each ws In ThisWorkbook.Worksheets
ws.Activate
valuerow = Cells.Find(What:="tva", After:=Range("A1"), LookIn:=xlValues, SearchDirection:=xlPrevious).Row
For irow = 1 To valuerow
If ws.Cells(irow, 1).Value <> Worksheets("Master").Cells(irow, 1).Value Then
ws.Cells(irow, 1).Interior.Color = vbYellow
End If
If ws.Cells(irow, 2).Value <> Worksheets("Master").Cells(irow, 2).Value Then
ws.Cells(irow, 2).Interior.Color = vbYellow
End If
Next
Next
End Sub
I am trying to figure out the cleanest way to create a dynamic range and this, I think, is close to what I want it to do but I am not sure how to make it correct. Any thoughts?
Sub Macro1()
Dim RNG As Range
With Sheets("Open Jobs Report") 'Change to your sheet
Set RNG = .Range("A1", .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column))
End With
Try this:
Dim RNG As Range
Set RNG = .Range("A1", .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column))
Because you were using . in front of some of the range objects I assume it is in a With Block like this:
Sub foooooii()
Dim RNG As Range
With Sheets("Sheet3") 'Change to your sheet
Set RNG = .Range("A1", .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column))
End With
Debug.Print RNG.Address
End Sub
building on Scott's solution and just to shorten it a little:
Set RNG = .Range(.Cells(.Rows.Count, "A").End(xlUp), .Cells(1, .Columns.Count).End(xlToLeft))
I would really appreciate some help to find a correct approach to solve my issue.
I am attempting to loop through all worksheets (except for "Sheet 1" and "Output".
All the above referenced worksheets contain data from cell A2 to last column and last row. I need to copy all the looped ranges (one below the other) in cell C2 in my "Output" worksheet.
Also I have a unique number in A1 in all worksheets (except for "Sheet 1" and "Output" that needs to be copied into B2 in my "Output" worksheet. The trick is (which i am struggling with) the value in A1 needs to be copied down B2 in my "Output" worksheet by the number A2:last row in all my looped worksheets.
Below is my code thus far:
Sub EveryDayImShufflingData()
Dim ws As Worksheet
Dim PasteSheet As Worksheet
Dim Rng As Range
Dim lRow As Long
Dim lCol As Long
Dim maxRow As Integer
Dim x As String
Set PasteSheet = Worksheets("Output")
Application.ScreenUpdating = False
'Loop through worksheets except "Sheet 1" and "Output"
For Each ws In ActiveWorkbook.Worksheets
If (ws.Name <> "Sheet1") And (ws.Name <> "Output") And (ws.Visible = True) Then
'Select the Worksheet
ws.Select
'With each worksheet
With ws
'Declare variables lRow and lCol
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
'Set range exc. VIN
Set Rng = .Range(.Cells(2, 1), .Cells(lRow, lCol))
'Paste the range into "Output" worksheet
Rng.Copy
PasteSheet.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
x = .Cells(1, 1).Value
For i = 1 To lRow
PasteSheet.Cells(i, 2).End(xlUp).Offset(1, 0) = x
maxRow = maxRow + 1
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End With
End If
Next ws
End Sub
Any assistance would be kindly appreciated
Try this:
Sub EveryDayImShufflingData()
Dim ws As Worksheet, copyRng As Range, lRow As Long, lCol As Long, PasteSheet As Worksheet
Set PasteSheet = Worksheets("Output")
For Each ws In ActiveWorkbook.Worksheets
If (ws.Name <> "Sheet1") And (ws.Name <> "Output") And (ws.Visible = True) Then
lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
lCol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column
Set copyRng = ws.Range(ws.Cells(2, 1), ws.Cells(lRow, lCol))
copyTargetCell = PasteSheet.Cells(Rows.Count, 3).End(xlUp).Row + 1
copyRng.Copy Destination:=PasteSheet.Range("C" & copyTargetCell)
Worksheets("Output").Range("B" & copyTargetCell & ":B" & (copyTargetCell + copyRng.Rows.Count - 1)) = ws.Range("A1")
End If
Next ws
End Sub
I have total email ids in COL A of Sheet 1 and bounced email ids in COL A of Sheet 2. I want to delete Sheet 1 values or entire rows based on values on Sheet 2.
I tried the following code but doesn't work.
Public Sub delete_selected_rows()
'look at sheet2, A1 through A3 for search values
For Each search_value In Worksheets("Sheet2").Range("A1:A3")
'as long as there is something to delete...
Do While Not Worksheets("Sheet1").Range("A1:A3"). _
Find(search_value.Value, lookat:=xlWhole) Is Nothing
'...delete that row
Worksheets("Sheet1").Range("A1:A3").Find(search_value.Value, _
lookat:=xlWhole).EntireRow.Delete
Loop
Next
End Sub
Any help ?
I would use this one:
Public Sub delete_selected_rows()
Dim rng1 As Range, rng2 As Range, rngToDel As Range, c As Range
Dim lastRow as Long
With Worksheets("Sheet1")
lastRow = .Cells(.Rows.Count,"A").End(xlUp).Row
Set rng1 = .Range("A1:A" & lastRow)
End With
Set rng2 = Worksheets("Sheet2").Range("A:A")
For Each c In rng1
If Not IsError(Application.Match(c.Value, rng2, 0)) Then
'if value from rng1 is found in rng2 then remember this cell for deleting
If rngToDel Is Nothing Then
Set rngToDel = c
Else
Set rngToDel = Union(rngToDel, c)
End If
End If
Next c
If Not rngToDel Is Nothing Then rngToDel.EntireRow.Delete
End Sub
Try this:
Sub Macro1()
Dim lrow As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
With ws1
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("B1:B" & lrow)
.Formula = "=IFERROR(MATCH(A1," & ws2.Name & "!A:A,0),"""")"
.Value = .Value
.AutoFilter 1, "<>"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
.AutoFilterMode = False
End With
End Sub
Please advise me how to change my code to select rows only if they have a value in BC column (ignore complete row if cell in BC column is blank):
Private Sub CommandButton3_Click()
Range("A:a,b:b,c:c,e:e,bc:bc").Select
Selection.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
End Sub
First run your code as is. Then perform the row deletions in the added workbook:
Sub dural()
Dim N As Long, I As Long, r As Range
N = Cells(Rows.Count, "BC").End(xlUp).Row
For I = N To 1 Step -1
Set r = Cells(I, "BC")
If IsEmpty(r) Then
r.EntireRow.Delete
End If
Next
End Sub
You could do this by using a filter:
Filter on column BC by unchecking (Blanks)
Copy the columns
Paste into a new worksheet or workbook
If it has to be VBA, here are two codes that will perform as desired.
This first code uses the autofilter:
Private Sub CommandButton3_Click()
Dim wsData As Worksheet
Dim wsNew As Worksheet
Set wsData = ActiveSheet
Set wsNew = Sheets.Add
With Intersect(wsData.UsedRange, wsData.Columns("BC"))
.Parent.AutoFilterMode = False
.AutoFilter 1, "<>"
Intersect(.SpecialCells(xlCellTypeVisible).EntireRow, wsData.Range("A:A,B:B,C:C,E:E,BC:BC")).Copy
wsNew.Range("A1").PasteSpecial xlPasteValues
wsNew.Range("A1").PasteSpecial xlPasteFormats
.AutoFilter
End With
wsNew.Move
Set wsData = Nothing
Set wsNew = Nothing
End Sub
This second, alternative code uses a find loop:
Private Sub CommandButton3_Click()
Dim rngFound As Range
Dim rngCopy As Range
Dim strFirst As String
Set rngFound = Columns("BC").Find("*", Cells(Rows.Count, "BC"), xlValues, xlWhole)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Set rngCopy = rngFound
Do
Set rngCopy = Union(rngCopy, rngFound)
Set rngFound = Columns("BC").Find("*", rngFound, xlValues, xlWhole)
Loop While rngFound.Address <> strFirst
End If
If Not rngCopy Is Nothing Then
Sheets.Add
Intersect(rngCopy.Parent.Range("A:A,B:B,C:C,E:E,BC:BC"), rngCopy.EntireRow).Copy
Range("A1").PasteSpecial xlPasteValues
Range("A1").PasteSpecial xlPasteFormats
ActiveSheet.Move
End If
Set rngFound = Nothing
Set rngCopy = Nothing
End Sub