I am trying to generate a list of data based on the contents of a group of filtered cells. First (in code not included), users select a criterion from a list box, which filters a list of 800 accounts down to the number that meet that criterion. From there, I need to grab the value from Column a and the row that corresponds to the visible cells. The issue is that I can't do a straight reference to the row, because when the rows are hidden, it is no longer a 1,2,3,4 etc sequential list. Here is the code I have, I know exactly where I need to specify the rows, just not how to do so
Sub AllProviders_Click()
Dim i As Integer
Dim vCount As Integer
vCount = Range("E18:E817").SpecialCells(xlCellTypeVisible).Count
MsgBox vCount 'for debugging
For i = 1 To vCount
Sheets("Provider Output").Cells(3, 2 + i) = 'and this is where I have no idea
Next i
End Sub
When the sub is run, the number of cells that are visible is stored in vCount, which is used to specify how many columns of data are going to be filled. My issue is line 7, where I need to specify the cells to pull.
Try:
Range("A18:A817").SpecialCells(xlCellTypeVisible).Copy _
Sheets("Provider Output").Cells(3, 3)
Edit: if that's not working for you then maybe try this -
Sub AllProviders_Click()
Dim i As Integer
Dim c As Range
i = 1
For Each c In Range("E18:E817").Cells
If Not c.EntireRow.Hidden Then
Sheets("Provider Output").Cells(3, 2 + i) = c.EntireRow.Cells(1).Value
i = i + 1
End If
Next c
End Sub
Related
I have an Excel table that is 6 columns wide (A-F) by 13,000 rows when it opens. I want to write a macro that will begin with cell B1 and check to see if it contains a specified letter (which I will put in another, unused cell). If it does, I want to delete the entire row and move the other rows up. Then the macro should begin again with the B1 and repeat the process. If B1 does not contain the specified letter, I want to successively check C1-F1. If any of them contain the specified letter, I want to delete that row, move the other rows up, and begin again with B1.
If none of the cells B1-F1 contain the specified letter, then I want to leave the row in the table. Then I want to begin testing the next row with B2 (or Bn) I want to continue this process until I have checked Fn in the last row with data, and have either kept or deleted that row.
What I want to be left with is a table containing all the rows from the original set where the specified letter appears in any of the cells in columns 2-6 of the row.
I have been away from Excel macros for twenty years, and so really need some pointers as to how to implement the row deletion, moving up the rows, and hard parts like that.
The fastest way to do this is build up a multiple-area range (that is a read-only operation that won't modify the worksheet) and then delete it in a single operation.
This VBA routine should do it:
Public Sub DeleteRowsHavingCriterion()
Dim J As Integer
Dim nrows As Integer
Dim ws As Worksheet
Dim UsedRange As Range
Dim toDeleteRange As Range
Dim ThisRow As Range
Dim DeleteThisRow As Boolean
Set ws = Application.ActiveWorkbook.Worksheets("WorksheetToProcess")
Set UsedRange = ws.UsedRange
Let nrows = UsedRange.Rows.Count
For J = nrows To 1 Step -1
Set ThisRow = UsedRange.Rows(J).EntireRow
DeleteThisRow = ( _
(ThisRow.Cells(1, 2).Value = "LetterForColumnB") Or _
(ThisRow.Cells(1, 3).Value = "LetterForColumnC") Or _
(ThisRow.Cells(1, 4).Value = "LetterForColumnD") Or _
(ThisRow.Cells(1, 5).Value = "LetterForColumnE") Or _
(ThisRow.Cells(1, 6).Value = "LetterForColumnF") _
)
If (DeleteThisRow) Then
If (toDeleteRange Is Nothing) Then
Set toDeleteRange = ThisRow
Else
Set toDeleteRange = Union(toDeleteRange, ThisRow)
End If
End If
Next J
If (Not (toDeleteRange Is Nothing)) Then
toDeleteRange.Delete (XlDeleteShiftDirection.xlShiftUp)
End If
End Sub
I have a worksheet with ~4,000 rows and 300 columns.
For my report, I have to remove a bunch columns and only keep about 50 of them, based on the header (in row 1).
I have the following code (obviously only listing 4 of the 50 columns) but this takes about 40 minutes to run. Is there a way to increase the performance of this?
Sub delete_columns()
Mylist = Array("ID","Status","First_Name","Last_Name")
LC = Cells(1, Columns.Count).End(xlToLeft).Column
For mycol = LC To 1 Step -1
x = ""
On Error Resume Next
x = WorksheetFunction.Match(Cells(1, mycol), Mylist, 0)
If Not IsNumeric(x) Then Columns(mycol).EntireColumn.Delete
Next mycol
End sub
Collect the columns you want to delete in a variable ColumnsToDelete first and delete all of them at once after the loop. Advantage of that is you have only one delete action (each action takes time) so this is less time consuming. Also you don't need to deactivate screen updating or calculation with this because this is already optimized to run only one update/calculation.
Option Explicit
Public Sub delete_columns()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") ' adjust your sheet name here!
Dim ColumnNames As Variant
ColumnNames = Array("ID", "Status", "First_Name", "Last_Name")
Dim LastColumn As Long
LastColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Dim ColumnsToDelete As Range
Dim iCol As Long
For iCol = 1 To LastColumn ' no need for backwards looping if we delete after loop.
Dim MatchedAt As Double
MatchedAt = 0
On Error Resume Next ' deactivate error reporting
MatchedAt = WorksheetFunction.Match(ws.Cells(1, iCol), ColumnNames, 0)
On Error Goto 0 'NEVER forget to re-activate error reporting!
If MatchedAt > 0 Then
If ColumnsToDelete Is Nothing Then ' add first found column
Set ColumnsToDelete = ws.Columns(iCol).EntireColumn
Else ' add all other found columns with union
Set ColumnsToDelete = Union(ColumnsToDelete, ws.Columns(iCol).EntireColumn)
End If
End If
Next mycol
' if columns were found delete them otherwise report
If Not ColumnsToDelete Is Nothing Then
ColumnsToDelete.Delete
Else
MsgBox "Nothing found to delete."
End If
End Sub
The first step would be to preface your Subroutine with
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
and end it with
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
This will mean that Excel doesn't try to recalculate the sheet every time you delete a column, it does it in one fell swoop at the end.
Unfortunately, we are working with Columns here, not Rows — otherwise, I'd suggest using a Filter to drop the Loop. Match can sometimes be a bit slow, so you may want to consider swapping the Array for a Dictionary, or having a Fuction to quickly loop through the Array and search for the value.
Not strictly a speed thing, but using Application.Match instead of WorksheetFunction.Match allows you to streamline your code inside the loop slightly:
If IsError(Application.Match(Cells(1, mycol).Value, Mylist, 0)) Then Columns(mycol).Delete
Keep only columns occurring in titles array
"For my report, I have to remove a bunch columns and only keep about 50 of them, based on the header (in row 1)."
The slightly shortened code in OP only lists 4 of the 50 headers in array MyList ; thus following MCV E rules
In the following example code I demonstrate a way to approve performance, explained in several steps;
in my tests it performed in 0.09 seconds over 3.000 rows (against nearly the same time of 0.10 seconds for #PEH 's methodically fine approach
, but which imho should be changed to If MatchedAt = 0 Then instead of > 0 to include the listed columns, not to delete them!)
[1] Don't focus on deletion (~250 columns), but get an array of column numbers to be maintained (~4..50 columns); see details at help function getNeededColNums()
showing an undocumented use of Application.Match()
[2] Hide the found columns to preserve them from eventual deletion
[3] Delete all columns left visible in one go using the SpecialCells method
[4] Redisplay the hidden columns left untouched
A main reason for the mentioned poor performance in the original post (OP) is that repeated deletion of columns shifts the entire worksheet up to 250 times (i.e. ~75% of titled columns).
A further note to the original post: always use Option Explicit to force variable declarations and fully qualify all range references,
e.g. like x = Application.Match(Sheet1.Cells(1, mycol), myList, 0).
Sub ExampleCall()
Dim t#: t = Timer
'[1]Get array of column numbers to be maintained
Dim ws As Worksheet: Set ws = Sheet1 ' << reference wanted sheet e.g. by Code(Name)
Dim cols: cols = getNeededColNums(ws) '1-based 1-dim array
Debug.Print Join(cols, ",")
'[2]Hide found columns to preserve them from eventual deletion
Dim i As Long
For i = 1 To UBound(cols)
ws.Columns(cols(i)).Hidden = True
Next
'[3]Delete columns left visible
Application.DisplayAlerts = False
ws.Range("A1", ws.Cells(1, LastCol(ws))).SpecialCells(xlCellTypeVisible).EntireColumn.Delete
Application.DisplayAlerts = True
'[4]Redisplay untouched hidden columns
ws.Range("A1", ws.Cells(1, UBound(cols))).EntireColumn.Hidden = False
Debug.Print "**" & Format(Timer - t, "0.00 secs") ' 0.09 seconds!
End Sub
'Help function getNeededColNums()
Note that Application.Match() doesn't compare only a single argument against a complete list of column titles, but is capable to pass even an array as first argument:
Application.Match(titles, allTitles, 0)
Assuming existing titles, this results in a 1-based array with the same dimension boundaries as the first argument and which returns the found column numbers. So you get valid list without need of further checks (IsNumeric or Not IsError in the late-bound Application form) or even error handling in the WorksheetFunction.
Function getNeededColNums(ws As Worksheet)
'Note: returns 1-based 1-dim array (assuming existant titles)
Dim titles As Variant
titles = Array("ID", "Status", "First_Name", "Last_Name")
'get all existing titles
Dim allTitles As Variant
allTitles = ws.Range("1:1").Resize(1, LastCol(ws)).Value2
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'get column numbers to be maintained
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
getNeededColNums = Application.Match(titles, allTitles, 0)
End Function
Help function LastCol()
Function LastCol(ws As Worksheet, Optional rowNum As Long = 1) As Long
'Purp.: return the last column number of a title row in a given worksheet
LastCol = ws.Cells(rowNum, ws.Columns.Count).End(xlToLeft).Column
End Function
I have a sheet with about 6000 rows. In my code I first filter out some rows.
Sheets("privata").Rows("2:" & Rows.count).AutoFilter Field:=26, Criteria1:=">=2020-01-30 09:00:00", Operator:=xlAnd, Criteria2:="<=2020-01-30 09:30:00"
Sheets("privata").Rows("2:" & Rows.count).AutoFilter Field:=24, Criteria1:="<>OK"
Sheets("privata").Rows("2:" & Rows.count).AutoFilter Field:=25, Criteria1:="<>SUPPLY_CONTROL,"
Its now down to about 350 rows. After I've filtered it I copy and paste the data to another sheet
Sheets("privata").UsedRange.Copy
Sheets("toptre").Range("A1").PasteSpecial xlPasteAll
After I've copied the data I work on it in various ways in the new sheet.
The entire code takes a while to run. After stepping through the code I discovered that the filtering out process is super quick. What takes time is the pasting of the data in to the other sheet.
Is there a possibility to work with the original filtered sheet? When I try to, it uses all 6000 rows, not just the filtered out ones.
Example of what I want to do:
For i = 2 To RowCount + 1
employee = Sheets("privata").Cells(i, 25)
onList = False
For j = 1 To UBound(employeeList)
If employee = employeeList(j) Then
onList = True
Exit For
End If
Next j
If onList = False Then
countEmployees = countEmployees + 1
employeeList(countEmployees) = employee
End If
If onList = True Then
onList = False
End If
Next i
When referring to Cells(2, 25) I want to refer to the second row in the filtered sheet. Which might be row 3568 in the sheet. Is that possible?
/Jens
After the filtering has been applied, you can make the copy/paste process very fast if you don't use a loop, but use Selection. For example:
Sub TryThis()
Dim r As Range
Sheets("privata").Select
Set r = ActiveSheet.AutoFilter.Range
r.Select
Selection.Copy Sheets("toptre").Range("A1")
End Sub
Usually you want to avoid Selection in VBA. However, you will end up with:
a block of data in sheet "toptre"
the block will include the header row and all visible rows
the block will be just a block (un-filtered)
I am not sure if this will make your process any faster, but it attempts to accomplish what you ask about in your question:
You could use the expression suggested by #GSerg 's comment to create a range object with only the visible rows in the data sheet, e.g.
Dim filteredRange As Range
Set filteredRange = Sheets("privata").UsedRange.Rows.SpecialCells(xlCellTypeVisible)
Assuming there is at least 1 visible row in the sheet (meaning that the above statement will not throw an error), you could then use the following function to access that range as if it were a single, contiguous range:
Function RelativeCell(rng As Range, ByVal row As Long, ByVal col As Long) As Range
Dim areaNum As Long: areaNum = 0
Dim maxRow As Long: maxRow = 0
Dim areaCount As Long: areaCount = rng.Areas.Count
Do While maxRow < row
areaNum = areaNum + 1
If areaNum > areaCount Then
Set RelativeCell = Nothing
Exit Function
End If
maxRow = maxRow + rng.Areas(areaNum).Rows.Count
Loop
Dim lastArea As Range: Set lastArea = rng.Areas(areaNum)
Set RelativeCell = lastArea.Cells(row - (maxRow - lastArea.Rows.Count), col)
End Function
To print all the filtered values in column B, for example, you could use the above method on the filteredRange object (set earlier) this way:
Dim r As Long: r = 1
Do
Dim cell As Range: Set cell = RelativeCell(filteredRange, r, 2)
If cell Is Nothing Then Exit Do
Debug.Print cell.Value
r = r + 1
Loop
To simplify the above code, you could also use a function to know the last relative row number in the filtered range using the following function:
Function RelativeCellLastRow(rng As Range) As Long
Dim r As Long: r = 0
Dim i As Long
For i = 1 To rng.Areas.Count
r = r + rng.Areas(i).Rows.Count
Next
RelativeCellLastRow = r
End Function
Then, the code to print all the filtered values in column B would be reduced to this:
Dim r As Long
For r = 1 To RelativeCellLastRow(filteredRange)
Debug.Print RelativeCell(testRng, r, 2).Value
Next
If you use RelativeCellLastRow, it would be good to ensure that it is only executed once, to avoid unnecessary recalculations. In the For loop above, it is only executed once, since VBA only executes the limits of a For loop before the first iteration. If you need the value several times, you can store it in a variable and use the variable instead.
The idea behind the RelativeCell function is that the range returned by the call to SpecialCells is a multi-area range, i.e. a range made up of several non-contiguous ranges. What relativeCell does is to skip through the non-contiguous areas until it finds the row number it is looking for. If the row number is beyond the total number of rows in the range, the function returns Nothing, so the calling code must be aware of this to avoid calling a method or property on Nothing.
It is also worth nothing that RelativeCell works on a range with hidden rows, not hidden columns. With hidden columns, the code becomes a little more complex, but the complexity can be encapsulated in the RelativeCell function without affecting the code that uses the function.
Again, I am not sure whether this will make your code faster. When I did some tests to emulate your scenario using a sheet with 6000+ rows and 30 columns of random strings, the copy/paste after the filtering ran very quickly, but it could be because of the machine I am using, the version of Excel that I am using (2016), or the data I used. Having said that, I hope the above code is of some help.
I apologize, this is my first crack at Excel VBA so excuse my lack of knowledge!
So I have a list of (currently) 3 names to assign to the days in column A in a repeating order in Excel.
Currently my VBA code allows it to populate the selected cells with the names in a repeating pattern (this part is good), however there are two pieces I need help with.
1- with current code, once it reaches the bottom of the names it checks for the blank box that would end that list and starts over at the tops as directed but it puts a blank cell first (see screenshot). How can I have it put next name without adding blank cell first?
2- I want to be able to (once this gets going)select the entire D column through what dates need to be filled and:
-check the lowest non blank box
-match to list and set the
counter to name below that so
it continues the name order
from the last person who was
assigned
This is code I have now:
Sub EXAMPLE()
Dim count As Integer
count = 0
For Each c In Selection
c.Value = Range("X1").Offset(count, 0).Value
If c.Value = "" Then count = -1 And c.Value = Range("x1").Offset(count, 0).Value
count = count + 1
Next c
End Sub
Sorry I know that was long, I hope this makes sense.
I think it's worth reading about arrays, as this task is ideally suited to their use. Your best bet would be to read the names into an array and then build a recurring array whose dimension is equal to the number of rows in your dates column (or selection, or however you want to define the size of the output range).
Code would look a little like this:
Dim v As Variant
Dim people() As Variant, output() As Variant
Dim rowCount As Long, i As Long, j As Long
Dim endRange As Range
'Read the list of names into an array.
'This just takes all data in column "X" -> amend as desired
With Sheet1
Set endRange = .Cells(.Rows.Count, "X").End(xlUp)
v = .Range(.Cells(1, "X"), endRange).Value
End With
'Sense check on the names data.
If IsEmpty(v) Then
MsgBox "No names in Column ""X"""
Exit Sub
End If
If Not IsArray(v) Then
ReDim people(1 To 1, 1 To 1)
people(1, 1) = v
Else
people = v
End If
'Acquire the number of rows for repeating list of names.
'This just takes all data in column "A" -> amend as desired
With Sheet1
Set endRange = .Cells(.Rows.Count, "A").End(xlUp)
rowCount = .Range(.Cells(3, "A"), endRange).Rows.Count
End With
'Sense check date data.
If endRange.Row < 3 Then
MsgBox "No dates in Column ""A"""
Exit Sub
End If
'Make a recurring array.
ReDim output(1 To rowCount, 1 To 1)
i = 1
Do While i <= rowCount
For j = 1 To UBound(people, 1)
output(i, 1) = people(j, 1)
i = i + 1
If i > rowCount Then Exit Do
Next
Loop
'Write the output to column "D"
Sheet1.Range("D3").Resize(UBound(output, 1)).Value = output
am working on sheet and using the vba for the first time and i love it. but been stuck in one thing for the last few days, after all the reading and searching can not figure how to do this part, here is the scenario I have:
locked sheet and workbook, user can only edit/entre values (numbers) in cells C8:G8 and I8:X8, column H always blank and host no value.
the user is able to hide columns in C8:G8 and I8:X8 if he need to use certain number of columns.
trying to set a macro to identify if a value has been entered more then once within the entire range C8:X8 (excluding H it is empty and any other columns if hidden)
I started with countif and give the perfect results only if all columns are visible:
Sub dup()
Application.EnableEvents = False
Dim x As Variant 'tried with range
Dim n As Variant 'tried with range
Dim rng1 As Range 'tried with variant
Set rng1 = Range("C8:X8")
For Each x In rng1.SpecialCells(xlCellTypeVisible)
If Application.WorksheetFunction.CountIf(rng1, x) > 1 Then
x.Offset(4) = "3" 'used for conditional formatting
Else
x.Offset(4) = "10" 'used for conditional formatting
End If
Next
Application.EnableEvents = True
End Sub
still work when some columns are hidden but it does check through hidden columns and this is not what i want (i want it to skip hidden columns)
some search and reading find out the countif is unable to get the cell property if visible or hidden. tried both options application.countif and application.worksheetfunction.countif
so tried application.match but no luck
For Each x In rng1
If Not IsEmpty(x) Then
n = Application.match(x.Value, rng1.Value, 0)
If Not IsError(n) Then
x.Offset(4) = "3"
Else
x.Offset(4) = "10"
End If
End If
Next
tried application.hlookup and not able to get the desired result :
For Each x In rng1
If Not IsEmpty(x) Then
n = Application.HLookup(x.Value, rng1.Value, 1, False)
If Not IsError(n) Then
x.Offset(4) = "3"
Else
x.Offset(4) = "10"
End If
End If
Next
it will match the cell itself and look only in the first part of the range C8:G8.
just to explain about the hidden columns situation, the user can hide/show 1,2,3,4 and 5 columns in the first range (if user select 2, only columns C8:D8 will be visible) same apply for range I8:X8, if user select 5 only I8:M8 will be visible) so there will be a case where a hidden column will be in between visible columns.
find few answers on how to use SumProduct(subtotal,...) as a formula only and could not covert it to a VBA.
any recommendation and advise will be appreciated.
Please try this solution.
Sub Dup()
Const Sep As String = "|" ' select a character that
' doesn't occur in Rng
Dim Rng As Range
Dim Arr As Variant
Dim SearchString As String
Dim n As Integer
Dim i As Integer
' needed only if you have event procedures in your project:-
Application.EnableEvents = False
Set Rng = Range("C8:X8")
Arr = Rng.Value
SearchString = Sep
For i = 1 To UBound(Arr, 2)
If Not Columns(Rng.Cells(i).Column).Hidden Then
SearchString = SearchString & Arr(1, i) & Sep
End If
Next i
For i = 1 To UBound(Arr, 2)
' skip blanks, incl. column H, & hidden cells
If (Not Columns(Rng.Cells(i).Column).Hidden) And (Len(Arr(1, i)) > 0) Then
n = InStr(SearchString, Sep & Arr(1, i) & Sep)
n = InStr(n + 1, SearchString, Sep & Arr(1, i) & Sep)
With Rng.Cells(i)
If .Column <> 8 Then ' skip column H
.Offset(4).Value = IIf(n > 0, 3, 10)
' Note that "3" is a string (text) whereas 3 is a number
' It's unusual to enter a number as text because it's use
' for calculations is greatly impaired.
' However, you may modify the above line to write strings
' instead of numbers.
End If
End With
End If
Next i
Application.EnableEvents = True
End Sub
The sub assigns all non-hidden values in the Range to to an array and then reads them into a string (SearchString) in which they are separated by a special character which can be re-defined. All values exist in this string at least once. The second loop looks for the existing value which must be both followed and preceded by the special character because "a" would be found in "ab", "a|" in "ba|" but "|a|" is unambiguous. Then a second search (Instr), starting from after where the first match was found, determines if a duplicate exists. The Iif function then sets the value in the cell 4 rows below the examined cell. Note that the array index is identical to the cell number in the range because of the way the array was created.
Since the Instr function will "find" a null string in position 1 and consider it a duplication by default, null strings aren't processed, not setting any number for the purpose of CF. Column H should therefore be omitted. However, if column H should have any value the CF number will still not be written.
As the sub is called by an event procedure the Application's EnableEvents property should be set in that procedure, not in the sub. This is for greater clarity of the code and has no bearing on the functionality unless the vent procedure also calls other procs.
#Variatus, Sorry to get back on this, after further tests i think i found an issue, if i try to hide any clomun from range C8:G8 (ex : G8 and let say it has same value as M8) the Arr will only look through C8:F8 only, for some reason it doesn't go all the way to X8, and it will mark M8 as duplicate.
or even if the duplicate value is withing I8:X8 it wont find it because the Arr stop at the first hidden cell from the first range
any advise will be appreciated