In the below code i'm trying to use a for loop through a filtered list.
Without the offset the loop is going through each field and copying the data multiple times. With the offset its skipping rows.
How can I rephrase this to only loop through each row once, and skip the header row?
'Offset Placement Wrong
Set rngVisible = activeSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Offset(1, 0)
For Each rngCell In rngVisible
Rows(rngCell.Row).Select
Selection.Copy
Sheets(2).Select
'Skip Headers
Cells(2 + rowsRelocated, 1).Select
activeSheet.Paste
Sheets(1).Select
'row increment
rowsRelocated = rowsRelocated + 1
Next
Restrict the range to one column of your filter.
Dim rngVisible As Range, RowsRelocated As Long, rngCell As Range
Set rngVisible = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible)
RowsRelocated = 0
For Each rngCell In rngVisible.Cells
If rngCell.Row > 1 Then
rngCell.EntireRow.Copy Sheets(2).Cells(2 + RowsRelocated, 1)
RowsRelocated = RowsRelocated + 1
End If
Next
You can copy all filtered visible data at once from Sheets(1) to Sheets(2)...
Sub test()
Dim allData As Range, FilteredData As Range, rngVisible As Range, TargetRange As Range
Set allData = Sheets(1).Range("A1").CurrentRegion
'Instead of currentregion you could mention actual range if it contains blank rows.
Set FilteredData = allData.Offset(1, 0).Resize(allData.Rows.Count - 1, allData.Columns.Count)
Set rngVisible = FilteredData.Cells.SpecialCells(xlCellTypeVisible)
Set TargetRange = Sheets(2).Range("A1").CurrentRegion.Offset(Sheets(2).Range("A1").CurrentRegion.Rows.Count, 0)
'Assuming that Row 1 in Sheets(2) is header, Copy visible data from A2
rngVisible.Copy TargetRange
End Sub
Related
I have a manual selection process that I have tried but failed to automate, so I am reaching out for help. I have attached an image of my Excel sheet as a visual guide when reading my process. Excel Snapshot.
I select cell "L2" and run the code below. It finds the first instance of the value within "A2:J1501" and cuts the whole row. It pastes the row onto the sheet named Lineups. Then it highlights each of the values of the cut row in column "L:L" to let me know that value has been used. I then manually select the next non-highlighted value (in the image example it would be "L2") and run the code again, and again, and again, until every row of L:L is highlighted. This process can take some time depending on the number of rows in L:L so I was hoping I can get some help to automate.
Thank you very much.
Sub ManualSelect()
Dim rng As Range
Set rng = Range("A1:J1501")
Dim ac As Range
Set ac = Application.ActiveCell
rng.Find(what:=ac).Select
Range("A" & ActiveCell.Row).Resize(1, 10).Cut
ActiveWindow.ScrollRow = 1
Sheets("Lineups").Select
nextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(nextRow, 1).Select
ActiveSheet.Paste
Sheets("Data").Select
Dim wsData As Worksheet
Dim wsLineups As Worksheet
Dim rngToSearch As Range
Dim rngLineupSet As Range
Dim rngPlayerID As Range
Dim Column As Long
Dim Row As Long
Dim LastRow As Long
Set wsData = Sheets("Data")
Set wsLineups = Sheets("Lineups")
Set rngPlayerID = wsData.Range("L2:K200")
Set rngToSearch = rngPlayerID
LastRow = wsLineups.Cells(Rows.Count, 1).End(xlUp).Row
For Row = 2 To LastRow
For Column = 1 To 10
Set rngLineupSet = rngPlayerID.Find(what:=wsLineups.Cells(Row, Column), LookIn:=xlValues)
If Not rngLineupSet Is Nothing Then rngLineupSet.Interior.Color = 65535
Next Column
Next Row
End Sub
This should be pretty close:
Sub ManualSelect()
Dim wsData As Worksheet, c As Range, dict As Object, v, rw As Range
Dim wsLineups As Worksheet, c2 As Range, f As Range
Set dict = CreateObject("scripting.dictionary") 'for tracking already-seen values
Set wsLineups = ThisWorkbook.Worksheets("Lineups")
Set wsData = ThisWorkbook.Worksheets("Data")
For Each c In wsData.Range("L2", wsData.Cells(Rows.Count, "L").End(xlUp))
v = c.Value
If dict.exists(CStr(v)) Then
c.Interior.Color = vbYellow 'already seen this value in L or a data row
Else
'search for the value in
Set f = wsData.Range("A2:J1501").Find(v, lookat:=xlWhole, LookIn:=xlValues, searchorder:=xlByRows)
If Not f Is Nothing Then
Set rw = f.EntireRow.Columns("A").Resize(1, 10) 'A to J
For Each c2 In rw.Cells 'add all values from this row to the dictionary
dict(CStr(c2)) = True
Next c2
rw.Cut Destination:=wsLineups.Cells(Rows.Count, "A").End(xlUp).Offset(1)
c.Interior.Color = vbYellow
Else
'will there always be a match?
c.Interior.Color = vbRed 'flag no matching row
End If
End If 'haven't already seen this col L value
Next c 'next Col L value
End Sub
I believe this should do it (updated):
Sub AutoSelect()
Dim wsData As Worksheet, wsLineups As Worksheet
Dim rng As Range, listIDs As Range
Set wsData = ActiveWorkbook.Sheets("Data")
Set wsLineups = ActiveWorkbook.Sheets("Lineups")
Set rng = wsData.Range("A2:J1501")
'get last row col L to define list
LastRowL = wsData.Range("L" & Rows.Count).End(xlUp).Row
Set listIDs = wsData.Range("L2:L" & LastRowL)
'loop through all cells in list
For i = 1 To listIDs.Rows.Count
myCell = listIDs.Cells(i)
'retrieve first mach in listID
checkFirst = Application.Match(myCell, listIDs, 0)
'only check first duplicate in list
If checkFirst = i Then
'get new row for target sheet as well (if sheet empty, starting at two)
newrow = wsLineups.Range("A" & Rows.Count).End(xlUp).Row + 1
'check if it is already processed
Set processedAlready = wsLineups.Cells(2, 1).Resize(newrow - 1, rng.Columns.Count).Find(What:=myCell, lookat:=xlWhole, LookIn:=xlValues)
'if so, color yellow, and skip
If Not processedAlready Is Nothing Then
listIDs.Cells(i).Interior.Color = vbYellow
Else
'get fist match for value, if any (n.b. "xlWhole" ensures whole match)
Set foundMatch = rng.Find(What:=myCell, lookat:=xlWhole, LookIn:=xlValues)
'checking for a match
If Not foundMatch Is Nothing Then
'get the row
foundRow = foundMatch.Row - rng.Cells(1).Row + 1
'specify target range and set it equal to vals from correct row in rng
wsLineups.Cells(newrow, 1).Resize(1, rng.Columns.Count).Value2 = rng.Rows(foundRow).Value
'clear contents rng row
rng.Rows(foundRow).ClearContents
'give a color to cells that actually got a match
listIDs.Cells(i).Interior.Color = vbYellow
Else
'no match
listIDs.Cells(i).Interior.Color = vbRed
End If
End If
Else
'duplicate already handled, give same color as first
listIDs.Cells(i).Interior.Color = listIDs.Cells(checkFirst).Interior.Color
End If
Next i
End Sub
Also, I think, slightly faster than the other solution offered (because of the nested loop there?). Update: I got a bit confused about the nested loop in the answer by Tim Williams, but I missed that you also want to "accept" the values in the list that matched on a row that is already gone. I fixed this in the updated version by checking if a value that fails to match on the data range has already been transferred to Lineups. Provided that doing so is permissible, this method avoids the nested loop.
I checked both methods for speed (n = 50) on a list (n = 200) for the full data range, ended up with average of 1.70x faster... But maybe speed is not such a big deal, if you're coming from manual labor :)
I am trying to utilise the VBA/macro function at work. However, I came across a problem which says something like 'error; insufficient memory' and after some browsing on the internet I realise that copy and pasting generally takes up a lot of spaces in the Excel and my Excel in workplace is only 32 bits. Therefore, does anyone know any good alternatives to ActiveSheet.Paste?
My codes are currently as following:
ActiveSheet.Range ("$A$!:$Y$1000").AutoFilter Field:=7, Criterial:=_banker
Range("A1").Select
Range(Selection, Selection.End(x1Down)).Select
Range(Selection, Selection.End(X1ToRight)).Select
Selection.Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
ActiveSheet.Name= banker
i=i+1
Loop
End Sub
You should copy your code as it is and no writing it. In this way you will avoid spelling mistakes (Range ("$A$!:$Y$1000") instead of "A1:..., X1ToRight instead of XlToRight, "_banker" instead of "banker"). Putting Option Explicit on top of your module, as recommended above will help.
A way to filter and copy the filter range, not involving the clipboard should be the next code. Please, test it and send some feedback:
Sub testFilterCopyRange()
Dim sh As Worksheet, shNew As Worksheet, lastR As Long
Dim banker As String, rng As Range, rngF As Range, arr, i As Long
Dim maxIt As Long 'number of iterations
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row
maxIt = 1 'set here the maximum number of necessary iterations
sh.AutoFilterMode = False 'eliminate the previous filter
Set rng = sh.Range("A1:H" & lastR) 'set the range to be processed
For i = 1 To maxIt
banker = "7" '"your dinamic criteria"
rng.AutoFilter field:=7, Criteria1:=banker 'filter the range according to above defined criteria
Set rngF = rng.SpecialCells(xlCellTypeVisible) 'set a range to keep the filtered cells in the range
arr = arrayFromDiscRange(rngF, False) 'header inclusive
Set shNew = Sheets.Add(After:=sh): shNew.Name = banker 'add a new sheet and name it
shNew.Range("A1").Resize(UBound(arr), UBound(arr, 2)).value = arr 'drop the array content at once
Next i
End Sub
'function able to transform a filtered (discontinue) range in an array:
Private Function arrayFromDiscRange(rngF As Range, Optional NoHeader As Boolean = False) As Variant
Dim arr, i As Long, j As Long, k As Long, A As Range, R As Range, iRows As Long
'count range rows
For Each A In rngF.Areas
iRows = iRows + A.rows.count
Next A
'Redim the array to keep the range
ReDim arr(1 To iRows - IIf(NoHeader, 1, 0), 1 To rngF.Columns.count): k = 1
For Each A In rngF.Areas 'iterate between the range areas:
For Each R In A.rows 'iterate between the area rows:
If NoHeader And k = 1 Then GoTo Later 'skip the first row, if no header wanted
For j = 1 To R.Columns.count 'iterate between the area row columns:
arr(k, j) = R.cells(1, j).value 'place each row cells value in the array row
Next j
k = k + 1 'intrement the array row to receive values
Later:
Next
Next A
arrayFromDiscRange = arr 'returning the created array
End Function
If something unclear, even if I tried commenting all the code line which could be problematic in understanding, please do not hesitate to ask for clarifications.
i am stuck with my procject again... I tried with formulas but i can t make it work or i can t make it right, and i couldn t find similar topic any where, here is the problem. As u can see in screenshot in this link https://ibb.co/FJRBxcM i have 2 worksheets, Sheet1 with some value generator, and Sheet"RadniNalog" where i copy&paste manualy certan values from Sheet1. My goal is to make it work automatically, when i paste data from another Workbook, as shown in screenshot example, i polulate range "A10:C27", range width is constant, always 3 column, but rows can change so number is X. Now i need values from "A10:A27" to copy to next empty column from left to right in Sheet"RadniNalog" from cells in 2nd row. Next i also need to copy Value from cell =F$13$ into the first row in sheet "RadniNalog" (on screenshot example its cell "E1" and that value from F13 needs to act like a Header for values belove it. If Value from header is the same as value in cell "F13" i need to continue adding values under existing ones, and if not move to the next available column. In screenshot example, if cell "D1" from sheet "RandiNalog" is same as cell "F13" in Sheet1, then values from range "A10:A27" should be added under last value in ColumnD. I need some VBA code if possible to make it work as wanted. Thanks in advance
Copy this code to Sheet1 module
This code runs the macro copyValuesToWs when you put the code in F13
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("F13:G13")) Is Nothing Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Call copyValuesToWs
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub
Create a new module and insert this code
Option Explicit
Function FindLastRow(ByVal Col As Byte, ws As Worksheet) As Long
FindLastRow = ws.Cells(Rows.Count, Col).End(xlUp).Row
End Function
Function FindLastColumn(ByVal rw As Byte, ws As Worksheet) As Long
FindLastColumn = ws.Cells(rw, Columns.Count).End(xlToLeft).Column
End Function
Sub copyValuesToWs()
Dim ws1 As Worksheet: Set ws1 = Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Sheets("Radni nalog")
Dim lCol As Long
Dim lRow As Long
Dim srcRng As Range
Dim dstRng As Range
Dim hdRng As Range
' Next row after ID
Dim idRng As Range: Set idRng = ws1.Range("A10")
' find last row value in column A
lRow = FindLastRow(1, ws1)
' range to be copied
Set srcRng = ws1.Range(ws1.Cells(idRng.Row, 1), ws1.Cells(lRow, 1))
' find last used column in sheet2
lCol = FindLastColumn(1, ws2)
' header range
Set hdRng = ws2.Range(ws2.Cells(1, 1), ws2.Cells(1, lCol))
' check if value exists in header
On Error Resume Next
Dim sValue As Double: sValue = Application.WorksheetFunction.Match(ws1.Range("F13").Value, hdRng, 0)
If Err.Number = 0 Then ' value exists
' find last row
Set dstRng = ws2.Cells(FindLastRow(sValue, ws2) + 1, sValue)
' paste values
srcRng.Copy
dstRng.PasteSpecial xlPasteValues
Else
' set destination range
Set dstRng = ws2.Cells(2, lCol + 1)
' set header value
ws1.Range("F13:G13").Copy
ws2.Cells(1, lCol + 1).PasteSpecial xlPasteValues
' paste values
srcRng.Copy
dstRng.PasteSpecial xlPasteValues
End If
On Error GoTo 0
Application.CutCopyMode = False
End Sub
If I filter data in column 2, I wanted to change the filtered row/s background color. Is it possible?
My intention is, if there is any filter on the column then I want to show that differently.
please see pictures below of the results I wanted to achieve:
Choosing values to Filter in Column 2
On change Color on Filtered Rows(Yellow)
Rows will go back to Original state when there is no filter
Try the next code, please:
Sub TESTColorFilteredRange()
Dim sh As Worksheet, lastR As Long, rng As Range, rngF As Range
Dim filtCol As Long 'column to be filtered
Dim filterCriteria As String 'set here your filter criteria
filtCol = 1 'column A:A. Change here according to your need
filterCriteria = "A" 'Set it your criteria. I ued "A" for testing reason...
Set sh = ActiveSheet
sh.cells.AutoFilter 'clear te filter if it exists
lastR = sh.cells(Rows.count, filtCol).End(xlUp).Row 'last row on the column to be filtered
Set rng = sh.Range(sh.cells(1, filtCol), sh.cells(lastR, filtCol)) 'set the range to be filtered
rng.AutoFilter field:=1, Criteria1:="=" & filterCriteria 'filter the range
Set rngF = rng.SpecialCells(xlCellTypeVisible) 'set the filtered cells range
rngF.Interior.Color = vbYellow 'color the filtered range interior
NotIntersect(rng, rngF).Interior.Color = xlNone 'uncolor the not filtered range interior
End Sub
Function NotIntersect(rng As Range, rngF As Range) As Range 'determines the not filtered range
Dim rngNI As Range, i As Long
For i = 1 To rng.Rows.count
If rng.cells(i, 1).EntireRow.Hidden Then
If rngNI Is Nothing Then
Set rngNI = rng.cells(i, 1)
Else
Set rngNI = Union(rngNI, rng.cells(i, 1))
End If
End If
Next i
If Not rngNI Is Nothing Then Set NotIntersect = rngNI
End Function
Test it and send some feedback, please.
NotIntersect is necessary to clear the coloring on the not filtered range. Otherwise, after some tests using different criteria, all the range cells will be colored...
I am trying to get a filtered range into an array, on my test data the array fArr has the proper dim and fLR is the proper count of the filter range
But filRange is always only the header range NOT the filtered range
How to get filRange to be the filtered range?
Or to the point how to get fArr to be an array of the filter data?
Thanks
Sub arrFilterdRng()
Dim fArr As Variant
Dim rRange As Range, filRange As Range, myCell As Range
Dim fLR As Long, rCtr As Long
'Remove any filters
ActiveSheet.AutoFilterMode = False
'~~> Set your range
Set rRange = Sheets("Z").UsedRange
With rRange
'~~> Set your criteria and filter
.AutoFilter Field:=3, Criteria1:="*"
Set filRange = .SpecialCells(xlCellTypeVisible).EntireRow
fLR = .Resize(, 1).SpecialCells(xlCellTypeVisible).Count
Debug.Print fLR
ReDim fArr(1 To fLR, 1 To .Columns.Count)
Debug.Print UBound(fArr, 1), UBound(fArr, 2)
rCtr = 0
For Each myCell In filRange.Columns(1)
rCtr = rCtr + 1
For cCtr = 1 To .Columns.Count
fArr(rCtr, cCtr) = myCell.Offset(0, cCtr - 1).value
Next cCtr
Next myCell
End With
'Remove any filters
ActiveSheet.AutoFilterMode = False
End Sub
My data looks like this (all text)
My feeling is that the wildcard in your criteria is causing the trouble.
"*" only works for strings, so if your data are numbers (including dates) then they would be removed by the filter (ie they wouldn't be visible), so you would indeed only have the header in your range.
If you want numerical values, then one way of doing it would be to define a value, say:
.AutoFilter Field:=3, Criteria1:=">0"
or, if you want limits:
.AutoFilter Field:=3, Criteria1:=">0", Operator:=xlAnd, Criteria2:="<10"
If, on the other hand, you just want anything but blank cells, then the syntax should be:
.AutoFilter Field:=3, Criteria1:="<>"
You should also be aware that if the filtered range contains non-contiguous ranges, then each 'separate' range would be contained within the Areas collection. This means something like filRange.Rows.Count would only return the row count of the first area; and you can get real difficulties when you try to Offset and/or Resize the filtered range. It's also not possible to directly read non-contiguous ranges into an array using the .Value property.
I'm not sure your code is the most efficient way of handling your task, but keeping the same structure it could look like this:
Dim rRange As Range, filRange As Range
Dim myArea As Range, myRow As Range, myCell As Range
Dim fArr() As Variant
Dim r As Long
With ThisWorkbook.Worksheets("Z")
.AutoFilterMode = False
Set rRange = .UsedRange
End With
With rRange
.AutoFilter Field:=3, Criteria1:=">0"
Set filRange = .SpecialCells(xlCellTypeVisible)
End With
With filRange
r = -1 'start at -1 to remove heading row
For Each myArea In filRange.Areas
r = r + myArea.Rows.Count
Next
ReDim fArr(1 To r, 1 To .Columns.Count)
End With
r = 1
For Each myArea In filRange.Areas
For Each myRow In myArea.Rows
If myRow.Row <> 1 Then
For Each myCell In myRow.Cells
fArr(r, myCell.Column) = myCell.Value
Next
r = r + 1
End If
Next
Next
Perhaps your data has more complexity, but you can simply assign the values of a range to an array with:
var = rng.SpecialCells(xlCellTypeVisible).Value
Thus no need to loop over the data.
Here's a working example with this simple grid of data:
This code:
Option Explicit
Sub arrFilterdRng()
Dim ws As Worksheet '<-- your worksheet
Dim rng As Range '<-- your range to filter
Dim var As Variant '<-- will hold array of visible data
Dim lng1 As Long, lng2 As Long
' get sheet; remove filters
Set ws = ThisWorkbook.Worksheets("Sheet2")
ws.AutoFilterMode = False
' get range; apply filter
Set rng = ws.UsedRange
rng.AutoFilter Field:=1, Criteria1:="x"
' assign visible range to array
var = rng.SpecialCells(xlCellTypeVisible).Value
' test array
For lng1 = LBound(var, 1) To UBound(var, 1)
For lng2 = LBound(var, 2) To UBound(var, 2)
Debug.Print var(lng1, lng2)
Next lng2
Next lng1
End Sub
Results in this on the sheet:
And the output to the Immediate window for the content of var is:
a
b
c
x
2
3
x
5
6