I would like to apply filter on a table based the values presented in cells A1:AG1. But the problem is when my data gets updated, sometimes i have values in other cells like AH,AI etc., The values available only on first row.
So i tried to add a loop for every cell, but it is not working. How to change my code to loop through every column in a single row. Help me
Dim ws As Worksheet
Dim str2 As Variant
Dim arr2() As String
Dim j As Long
Dim rng As Range
Set ws = Sheets("Main")
Set Tbl = Sheet2.ListObjects("DataTable")
Set rng = Range("A1:AG1") 'Need to change
j = 1
For Each cell In rng
str2 = cell.Value
ReDim Preserve arr2(j)
arr2(j) = str2
j = j + 1
Next cell
Tbl.Range.AutoFilter Field:=12, Criteria1:=arr2, Operator:=xlFilterValues
End sub
How about something like below:
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim arr2() As String
Dim i As Long
Set ws = Sheets("Main")
Set ws2 = Sheets("Sheet2")
Set Tbl = ws2.ListObjects("DataTable")
LastCol = ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column
'above will give you the last column number in row one of sheet ws2
ReDim Preserve arr2(1 To LastCol) 're-size the array
'Set rng = Range("A1:A" & LastCol) 'set your range from column 1 to last
For i = 1 To LastCol 'loop through columns
arr2(i) = ws2.Cells(1, i).Value 'add value to array
'above number 1 represents Row 1, and i will loop through columns
Next i
Tbl.Range.AutoFilter Field:=12, Criteria1:=arr2, Operator:=xlFilterValues
'above will filter table column 12 with array values?
I do not know if I understood your question well, but just replace:
Set rng = Range("A1:AG1")
With:
Set rng = ws.range(ws.cells(1 , 1) , ws.cells(1 , ws.Cells.Columns.Count).End(xlToLeft).Column
Related
I have 2 sheets. Sheet1 has 2 rows: column names and values.
Sheet 2 is a master sheet with all the possible column names in. I need to copy the values from sheet 1 into their appropriate column.
I think i can do this via a match function, and so far i have this:
Sub dynamic_paste()
Dim Columnname As String
Dim inputvalue As String
Dim starter As Integer
Dim i As Integer
starter = 0
For i = 1 To 4
'replace 4 with rangeused.rows.count?
Sheets("sheet1").Select
Range("a1").Select
ActiveCell.Offset(0, starter).Select
Columnname = ActiveCell
'sets columnname variable
ActiveCell.Offset(1, 0).Select
inputvalue = ActiveCell
'sets inputname variable
Sheets("sheet2").Select
'**Cells(0, WorksheetFunction.Match(Columnname, Rows(1), 0)).Select**
Range("a1").Offset(1, starter).Value = inputvalue
'inputs variable in the next cell along
starter = starter + 1
Next
End Sub
I need to find out how to use my columnname variable as the matching value, and then offset down to the first row that is empty - then change the value of that cell to the variable called inputvalue.
For extra points: I need to make sure the code doesnt break if they dont find a matching value, and if possible put any values that dont match into the end of the row?
What about this:
Dim LR As Long, X As Long, LC As Long, COL As Long
Dim RNG As Range, CL As Range
Option Explicit
Sub Test()
LR = Sheets(2).Cells.SpecialCells(xlCellTypeLastCell).Row 'Get last used row in your sheet
LC = Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column 'Get last used column in your sheet
Set RNG = Sheets(2).Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(1, LC))
'Loop through all the columns on your sheet with values
For X = 1 To Sheets(1).Cells(1, Sheets(1).Columns.Count).End(xlToLeft).Column
Set CL = RNG.Find(Sheets(1).Cells(1, X).Value, lookat:=xlWhole)
If Not CL Is Nothing Then
COL = CL.Column
Sheets(2).Cells(LR + 1, COL).Value = Sheets(1).Cells(2, X).Value 'Get the value on LR offset by 1
Else
Sheets(2).Cells(1, Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column).Value = Sheets(1).Cells(1, X).Value
Sheets(2).Cells(LR + 1, Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column).Value = Sheets(1).Cells(2, X).Value
End If
Next X
End Sub
This way you will avoid using select. Which is very recommandable!
This is Sheet1:
This is Sheet2:
This is the code:
Option Explicit
Sub DynamicPaste()
Dim col As Long
Dim wks1 As Worksheet: Set wks1 = Worksheets(1)
Dim wks2 As Worksheet: Set wks2 = Worksheets(2)
For col = 1 To 3
Dim currentRow As Long
currentRow = WorksheetFunction.Match(wks2.Cells(1, col), wks1.Columns(1))
wks2.Cells(2, col) = wks1.Cells(currentRow, 2)
Next col
End Sub
This is Sheet2 after the code:
This is a must-read - How to avoid using Select in Excel VBA
Hi there I am trying to select a range "A2:H2" down to the last filled cell based on column A (so in this case it should select "A2:H59"). The range is not fixed so it cannot be defined with exact numbers. I have the following code, but it selects everything down to the 402nd row even though there is no data beyond "A59" in the sheet. Any idea what is going on? Thanks for the help!
Global ssaw As Worksheet
Global trckr As Worksheet
Sub DataF()
Dim myRange As Range
Dim myCell As Range
Set ssaw = Sheets("SSAW_DATA")
Set trckr = Sheets("SQL_DATA_FEED")
Set myRange = trckr.Range("A2:H2").end(xlDown)
With myRange
.SpecialCells(xlCellTypeBlanks).Interior.Color = RGB(255, 102, 102)
.SpecialCells(xlCellTypeBlanks).Value = "#missing#"
End With
End Sub
If we assume your last used cell in column A is A59 then …
… This
Set myRange = trckr.Range("A2", trckr.Range("A2").End(xlDown))
will select A2:A59 and this
.Resize(ColumnSize:=8)
will resize it to make it 8 columns width that is A2:H59.
So together we get:
Set myRange = trckr.Range("A2", trckr.Range("A2").End(xlDown)).Resize(ColumnSize:=8)
Use this
trckr.Range("A" & trckr.Rows.Count).End(xlUp)
alternatively to find the last used cell in column A if there can be empty cells in between:
Set myRange = trckr.Range("A2", trckr.Range("A" & trckr.Rows.Count).End(xlUp)).Resize(ColumnSize:=8)
exploit the fact that Range(cell1, cell2) is equivalent to Range(cell2, cell1)
Set myRange = trckr.Range("H2", trckr.Range("A2").End(xlDown))
while if you want to select a range from A2:H2 down to column A last not empty cell (i.e. included empty cells along column A in between the first and last not empty ones):
Set myRange = trckr.Range("H2", trckr.Cells(trckr.Rows.Count, 1).End(xlUp))
I would suggest to use the following code
Option Explicit
Function LastRowInColumn(colName As String)
Dim lastRow As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, colName).End(xlUp).Row
End With
LastRowInColumn = lastRow
End Function
Sub SelectRg()
Dim rg As Range
Dim wks As Worksheet
Dim lastRow As Long
lastRow = LastRowInColumn("A")
Debug.Print lastRow
If lastRow = 1 Then
' do nothing
Else
Set wks = ActiveSheet
With wks
Set rg = Range(.Cells(2, 1), .Cells(lastRow, "H"))
rg.Select
End With
End If
End Sub
The code determins the last filled row in column A and select based on this information everything to column H
EDIT Improved function
Function LastRowInColumn(ByVal wks As Worksheet, ByVal colName As String) As Long
With wks
LastRowInColumn = .Cells(.Rows.Count, colName).End(xlUp).Row
End With
End Function
EDIT2 And if one would not like to use an extra function you could do it like that
Sub SetRg()
Dim rg As Range
Dim wks As Worksheet
Dim lastRow As Long
Set wks = ActiveSheet
With wks
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'lastRow = LastRowInColumn(wks, "A")
If lastRow > 1 Then
Set rg = Range(.Cells(2, 1), .Cells(lastRow, "H"))
End If
End With
End Sub
I have two sheets. In both sheets I have a column (B) where each row is a different name:
Sheet 'A' has names in the column, these names are 'leading'.
Sheet 'B' also has names in this column, these names CAN BE outdated.
What I want: A macro which can check the names.
delete the names in Sheet B which are not (anymore) in Sheet A (delete entire affecting row)
Add the names from sheet A which are not (yet) in sheet B in new rows
What I have so far:
Sub DeleteRowsThatDoNotMatch()
Dim rng As Range
Dim Rng1 As Range, Rng2 As Range
Dim thisRow As Long
Dim arr1 As Variant
Dim arr2 As Variant
Dim dic2 As Variant
Dim OutArr As Variant
xTitleId = "Test"
Set Rng1 = Application.Selection
Set Rng1 = Application.InputBox("Welke data moet gewijzigd worden? :", xTitleId, Rng1.Address, Type:=8)
Set Rng2 = Application.InputBox("Selecteer de nieuwe waardes:", xTitleId, Type:=8)
Set Rng1 = Rng1.Columns(1)
Set dic2 = CreateObject("Scripting.Dictionary")
arr2 = Rng2.Value
For i = 1 To UBound(arr2, 1)
xKey = arr2(i, 1)
dic2(xKey) = ""
Next
thisRow = Rng1.Rows.Count
Do While thisRow > 0
If Not dic2.Exists(Rng1.Cells(thisRow, 1).Value) Then
Rng1.Cells(thisRow, 1).EntireRow.Delete
End If
thisRow = thisRow - 1
Loop
End Sub
This works as expected; the problem is adding the names which ARE in Sheet A but not (yet) in Sheet B.
I wrote a code to copy Column D, H, M and paste it on a brand new sheet starting from A-C. I first find the last row , after that I Union the 3 column range together then select the sheet and paste it.
For some reason I don't understand why it does not work. I have never used Union range before so not sure if that is the problem, or if it is something like my for loop. Help would be appreciated.
Dim ws As Worksheet
Dim lastRow As Integer
'for loop variables
Dim transCounter As Integer
Dim range1 As Range
Dim range2 As Range
Dim range3 As Range
Dim multipleRange As Range
Dim lastRow1 As Integer
Dim ittercell As Integer
Set ws = ActiveSheet
For transCounter = 1 To 10
r.AutoFilter Field:=6, Criteria1:=transCounter.Value, Operator:=xlFilterValues
With Application.ActiveSheet
lastRow1 = .Cells(.Rows.Count, "AE").End(xlUp).Row
End With
Set range1 = Sheets("Sheet1").Range("D6:D" & lastRow1).SpecialCells(xlCellTypeVisible)
Set range2 = Sheets("Sheet1").Range("H6:I" & lastRow1).SpecialCells(xlCellTypeVisible)
Set range3 = Sheets("Sheet1").Range("M6:M" & lastRow1).SpecialCells(xlCellTypeVisible)
Set multipleRange = Union(range1, range2, range3)
multipleRange.Copy
Sheets("O1 Filteration").Select
'Range("A3").Select
'Range("A3").PasteSpecial xlPasteValues
ittercell = 1
Cells(3, ittercell).PasteSpecial xlPasteValues
ittercell = ittercell + 6
Next transCounter
There's a couple of issues with your code that might be causing the fault:
r is not defined in your code
use of transCounter.Value instead of just CStr(transCounter) (see #QHarr comment)
iterCell reset every iteration of the loop (see #QHarr comment)
Combination of ActiveSheet, unqualified Cells(... and manual Select on sheets makes the Range qualifications ambiguous
However, I do think the main logic of using Union, then Copy, then PasteSpecial is OK and just some tweaking is required.
Here is some working code where you update the Worksheet and Range references with your own. Please follow the comments.
Option Explicit
Sub CopyUnionColumns()
Dim wsSource As Worksheet '<-- Sheet1 in your code
Dim wsTarget As Worksheet '<-- O1 Filteration in your code
Dim rngFilter As Range '<-- main data range on Sheet1
Dim rngSource As Range '<-- to hold Union'd data after filtering
Dim rngTarget As Range '<-- range in O1 Filteration to paste code to
Dim lngLastRow As Long '<-- last row of main data
Dim lngCounter As Long '<-- loop variable
Dim lngPasteOffsetCol As Long '<-- offset column for pasting in the loop
' set references to source and target worksheets
Set wsSource = ThisWorkbook.Worksheets("Sheet2") '<-- update for your workbook
Set wsTarget = ThisWorkbook.Worksheets("Sheet3") '<-- update for your workbook
' set reference to data for filtering in source worksheet
lngLastRow = wsSource.Cells(wsSource.Rows.Count, 6).End(xlUp).Row
Set rngFilter = wsSource.Range("A1:F" & lngLastRow)
' initialise offset column
lngPasteOffsetCol = 0
' iterate rows
For lngCounter = 1 To 10
' filter data the data per the counter
rngFilter.AutoFilter Field:=6, Criteria1:=CStr(lngCounter), Operator:=xlFilterValues
' set source range as union of columnar data per last row
Set rngSource = Application.Union( _
wsSource.Range("A1:A" & lngLastRow).SpecialCells(xlCellTypeVisible), _
wsSource.Range("C1:C" & lngLastRow).SpecialCells(xlCellTypeVisible), _
wsSource.Range("E1:E" & lngLastRow).SpecialCells(xlCellTypeVisible))
' set target range on target sheet top left cell and offset column
Set rngTarget = wsTarget.Range("A1").Offset(0, lngPasteOffsetCol)
' copy source cells
rngSource.Copy
' paste to target
rngTarget.PasteSpecial Paste:=xlPasteAll
' increment offset
lngPasteOffsetCol = lngPasteOffsetCol + 6
Next lngCounter
' cancel cut copy mode
Application.CutCopyMode = False
' cancel autofilter
wsSource.AutoFilterMode = False
End Sub
I'm trying to compare cell values between 2 Sheets (Sheet1 & Sheet2) to see if they match, and if they match move the matching values in Sheet1 to a pre-existing list (Sheet3) and delete the values in Sheet1 afterwards.
I'm using the reverse For Loop in Excel VBA, but everything works until the part where I start deleting the row using newrange1.EntireRow.Delete.
This throws a '424' Object Required Error in VBA and I've spent hours trying to solve this, I'm not sure why this is appearing. Am I selecting the row incorrectly? The object?
Would appreciate if anyone can point me to the correct direction.
Here's my code:
Sub Step2()
Sheets("Sheet1").Activate
Dim counter As Long, unsubListCount As Long, z As Long, x As Long, startRow As Long
counter = 0
startRow = 2
z = 0
x = 0
' Count Sheet3 Entries
unsubListCount = Worksheets("Sheet3").UsedRange.Rows.Count
Dim rng1 As Range, rng2 As Range, cell1 As Range, cell2 As Range, newrange1 As Range
' Select all emails in Sheet1 and Sheet2 (exclude first row)
Set rng1 = Worksheets("Sheet1").Range("D1:D" & Worksheets("Sheet1").UsedRange.Rows.Count)
Set rng2 = Worksheets("Sheet2").Range("D1:D" & Worksheets("Sheet2").UsedRange.Rows.Count)
' Brute Loop through each Sheet1 row to check with Sheet2
For z = rng1.Count To startRow Step -1
'Cells(z, 4)
Set cell1 = Worksheets("Sheet1").Cells(z, "D")
For x = rng2.Count To startRow Step -1
Set cell2 = Worksheets("Sheet2").Cells(x, "D")
If cell1.Value = cell2.Value Then ' If rng1 and rng2 emails match
counter = counter + 1
Set newrange1 = Worksheets("Sheet1").Rows(cell1.Row)
newrange1.Copy Destination:=Worksheets("Sheet3").Range("A" & unsubListCount + counter)
newrange1.EntireRow.Delete
End If
Next
Next
End Sub
Here's the error I'm getting:
Your inner loop produces a lot of step-by-step work that is better accomplished with Application.Match. Your use of .UsedRange to retrieve the extents of the values in the D columns is better by looking for the last value from the bottom up.
Option Explicit
Sub Step2()
Dim z As Long, startRow As Long
Dim rng2 As Range, wk3 As Worksheet, chk As Variant
startRow = 2
z = 0
Set wk3 = Worksheets("Sheet3")
' Select all emails in Sheet1 and Sheet2 (exclude first row)
With Worksheets("Sheet2")
Set rng2 = .Range(.Cells(2, "D"), .Cells(.Rows.Count, "D").End(xlUp))
End With
With Worksheets("Sheet1")
For z = .Cells(.Rows.Count, "D").End(xlUp).Row To startRow Step -1
chk = Application.Match(.Cells(z, "D").Value2, rng2, 0)
If Not IsError(chk) Then
.Cells(z, "A").EntireRow.Copy _
Destination:=wk3.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
.Cells(z, "A").EntireRow.Delete
End If
Next
End With
End Sub
As noted by Ryan Wildry, your original problem was continuing the loop and comparing after deleting the row. This can be avoided by adding Exit For after newrange1.EntireRow.Delete to jump out of the inner loop once a match was found. I don't think you should 'reset cell1' as this may foul up the loop iteration.
I think what's happening is when you are deleting the row, you are losing the reference to the range Cell1. So I reset this after the deletion is done, and removed the reference to newRange1. Give this a shot, I have it working on my end. I also formatted the code slightly too.
Option Explicit
Sub Testing()
Dim counter As Long: counter = 0
Dim z As Long: z = 0
Dim x As Long: x = 0
Dim startRow As Long: startRow = 2
Dim Sheet1 As Worksheet: Set Sheet1 = ThisWorkbook.Sheets("Sheet1")
Dim Sheet2 As Worksheet: Set Sheet2 = ThisWorkbook.Sheets("Sheet2")
Dim Sheet3 As Worksheet: Set Sheet3 = ThisWorkbook.Sheets("Sheet3")
Dim rng1 As Range: Set rng1 = Sheet1.Range("D1:D" & Sheet1.UsedRange.Rows.Count)
Dim rng2 As Range: Set rng2 = Sheet2.Range("D1:D" & Sheet2.UsedRange.Rows.Count)
Dim unsubListCount As Long: unsubListCount = Sheet3.UsedRange.Rows.Count
Dim cell1 As Range
Dim cell2 As Range
Dim newrange1 As Range
' Brute Loop through each Sheet1 row to check with Sheet2
For z = rng1.Count To startRow Step -1
Set cell1 = Sheet1.Cells(z, 4)
For x = rng2.Count To startRow Step -1
Set cell2 = Sheet2.Cells(x, 4)
If cell1 = cell2 Then
counter = counter + 1
Set newrange1 = Sheet1.Rows(cell1.Row)
newrange1.Copy Destination:=Sheet3.Range("A" & unsubListCount + counter)
newrange1.EntireRow.Delete
Set newrange1 = Nothing
Set cell1 = Sheet1.Cells(z, 4)
End If
Next
Next
End Sub