I have multiple sheets, each with 1 only 1 table at various widths and heights.
I am trying to achive:
once user have selected sheet via combobox, (this works)
then i can list the headers from the table on that sheet.
my possible solution idea:
My idea was to list the table headers in a combobox on a userform.
i count columns on selected sheet, works
for loop through the columns to grab the header name from each and stack into combobox.list,
code:
Private Sub chcSite_Change()
Dim siteSheet As String
siteSheet = WorksheetFunction.VLookup(Me.chcSite.Value, Worksheets("Overview").Range("SiteTable"), 2, False)
Me.chcRange.Enabled = True ' enables combobox for headers list
Dim COLS As Integer
COLS = Worksheets(siteSheet).ListObjects(1).ListColumns.Count
Dim i As Integer
i = 1
For i = 1 To COLS
If Worksheets(siteSheet).Cells(Columns(i), 1) = "" Then Exit For ' if header is empty = also end of table cols.
MsgBox Worksheets(siteSheet).Cells(Columns(i), 1) ' debug to see what it returns.
Next i
'Me.chcRange.List = Worksheets(siteSheet).ListObjects(1).ColumnHeads ' random test of columnheads
End Sub
as you can see i was exspecting Worksheets(siteSheet).Cells(Columns(i), 1) to return something, but it appears it is only a pointer/selector.
You might benefit from reading The VBA Guide To ListObject Excel Tables.
For example to get the 3rd heading of a table use
.ListObjects("Table1").HeaderRowRange(3)
The ListObject has its own row/column numbering and may be different from the sheets row/column numbering.
It should look something like this:
Dim i As Long 'always use Long
'i = 1 not needed
For i = 1 To COLS
' v-- this part is not needed …
If Worksheets(siteSheet).ListObjects(1).HeaderRowRange(i) = "" Then
Exit For ' if header is empty = also end of table cols.
End If
' ^-- … because headers of ListObjects can not be empty by definition.
' And HeaderRowRange can only access the headers of the ListObjects.
MsgBox Worksheets(siteSheet).ListObjects(1).HeaderRowRange(i) ' debug to see what it returns.
Next i
So you can shorten it to:
Dim i As Long
For i = 1 To COLS
MsgBox Worksheets(siteSheet).ListObjects(1).HeaderRowRange(i) ' debug to see what it returns.
Next i
Note that Cells(Columns(i), 1) could not work because eg Columns(2) references the complete column B (it is a range representing the full column 2) and Cells needs a row/column number like Cells(row, column).
Related
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 2 excel sheets : one containing the source data and one contains the goal data. i have created userform that contains comboboxes(dropdownlists)and import button .
there are comboboxes that contain the names of the first row of the Source sheet and other comboboxes that contain the names of the first row of the goal sheet.
i want to compare the names in the comboboxes ( source and goal names) and match them if they are equal
than when i click on import Button , everything in the source excel sheet will be imported in the goal excel sheet in the right place.
how can i do that ?
I TRIED THIS CODE
dim sh =ThisWorkbook.Sheets("sourcedata")
dim sh2= ThisWorkbook.Sheets("goaldata")
dim i,j as integer
for i = 1 to Application.WorksheetFunction.CountA(sh.Range("1:1"))
for j = 1 to Application.WorksheetFunction.CountA(sh2.Range("1:1"))
if sh.cells(1,i).value = sh2.cells(1,j).value then
Me.comboBox1.value = sh.cells(1,i)
Me.comboBox2.value = sh2.cells(1,j)
Me.comboBox3.value = sh.cells(1,i)
Me.comboBox4.value = sh.cells(1,j)
end if
next
next
end sub
the problem that i get usually the same value in all comboboxes.
i want to get in all comboboxes the names of the rows in both sheets.
for example i have the rows names of the Source sheet : Date , Event and place
the rows names in the goal sheet are : Date and Event only
for example : in combobox1.value= Date should also in comboBox2.value = Date (because Date exists in both sheets)
combBox3.value = Event and Combobox 4.value should be Event
I want to insert Combobox5.value = place ( combobox 5 contain the names that exist only in one sheet and they don't have any match )
Any help?
I think I understood the 3 combobox part but not completely the "which data should be copied" part so let's already advance on the combobox part.
Some notes about your code:
When you don't mention a dataType in you dim the vars are by default in variant type => e.g. dim i => is the same as dim i as variant. although not always a problem it could lead to unexpected behaviour;
The "combobox.value" is to get the selected value of the combobox, not to add items to it. Looking at your desc. and code I think you intented to add items.
So hereunder a revised version based on my assumptions. instead of using the "add ..Item" I just assigned the sheet cells to arrays as we can then manipulate these directly in memory, allowing operations like comparing, copying, etc.. to be performed much faster.
Option Explicit
Sub UserForm_Initialize()
Dim arr, arr2
arr = Sheet1.Range("A1:c1").Value2
Me.ComboBox1.List = Application.WorksheetFunction.Transpose(arr)
arr2 = Sheet2.Range("A1:c1").Value2
Me.ComboBox2.List = Application.WorksheetFunction.Transpose(arr2)
Dim i As Long, arr3, ii As Long: ii = 1
ReDim arr3(1 To 1, 1 To UBound(arr, 2))
For i = 1 To UBound(arr, 2)
If arr(1, i) <> arr2(1, i) Then
arr3(1, ii) = arr(1, i)
ii = ii + 1
End If
Next i
Me.ComboBox3.List = Application.WorksheetFunction.Transpose(arr3)
End Sub
Have a look at it and let me know how it went.
I have an excel file where I load the column headers dynamically from Row 2 across until I hit a null and put all those values into a list box transposed. This part is working as I expect it to.
My question is, how do I use the list box items to select the entire column that the named header exists in?
So in A2 B2 C2 I have the headers called Widget 1, 2, 3 respectively loaded into the listbox. Those load in order in the list box when the userform loads. In the list box, I would like to be able to click Widget 2 and 3 and have those entire columns selected. I don't want it hard coded, as I want it to be a selection as I could select widget 1 and 3 or any random selection as needed.
I could have as many as 50 widgets....so those will all load in the listbox on startup, I need to be able to select any of those values and have them select their corresponding column....
That is where I'm having issues, how to make the multi select happen.
Thanks in advance for any help.
EDITS:
This is the code used on the Private Sub UserForm_Initialize()
'Figure out how many actual columns headers there are and then search for signal names
'Dim Lastcol As String
Dim FoundColumnRangeCalculated As Variant
Dim Lastcol As Variant
Dim FoundColumnRange As Variant
With ActiveSheet
Lastcol = .Cells(2, .Columns.Count).End(xlToLeft).Column
''MsgBox Lastcol
End With
'Convert numerical column location to letter value to use as dynamic range header lookup
Dim NumberToColumn As Variant
Dim SearchColumn
SearchColumn = Lastcol
NumberToColumn = Left(Cells(1, SearchColumn).Address(1, 0), InStr(1, Cells(1, SearchColumn).Address(1, 0), "$") - 1)
'MsgBox NumberToColumn
'Build the actual range from found column headers
FoundColumnRangeCalculated = "A2:" & (NumberToColumn & Lastcol)
'Transfer headers vertically to the list box for user to see
ListBox1.List = Application.WorksheetFunction.Transpose(Range(FoundColumnRangeCalculated))
Imported List Box Transposed on UserForm Load
So now when I click or multi click (not shown in this image, but multi with choose options to be enabled) the item(s), I would like the corresponding column it represents to be selected when each item is clicked.
Columns that the items are drawn from
Since they are built in "order" from left to right, I assume it is a 1:1 match and search and select, but I'm having trouble trying to sort that piece of it out..lots of examples about getting it's data, parsing, etc.....I just simply need a "When listbox items selected, use selection to enable its column".
The columns can't be hard coded for range as the headers could be A:F, A:AA, or A:ZZ.......so it has to be a dynamic matching.
Thanks to those that responded, hopefully this edited post and images satisfy the on hold status.
To select multiple columns may try something like
Option Explicit
Private Sub ListBox1_Change()
Dim Ws As Worksheet, Rng As Range, c As Range, Sel As Range
Dim i As Long, Xval As Variant
Set Ws = ThisWorkbook.Sheets("Sheet1")
Set Rng = Ws.Range(Ws.Cells(2, 1), Ws.Cells(2, Me.ListBox1.ListCount))
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) Then
Xval = Me.ListBox1.List(i)
Set c = Rng.Find(Xval, LookIn:=xlValues)
If Not c Is Nothing Then
If Sel Is Nothing Then
Set Sel = Ws.Columns(c.Column)
Else
Set Sel = Union(Sel, Ws.Columns(c.Column))
End If
End If
End If
Next
If Not Sel Is Nothing Then
Sel.Select
End If
End Sub
In a case if you want to iterate through header's cells. It selects multiple columns for one widget if it's name matched more than once.
Works with ActiveSheet.
Dim result As Range
Dim criteria As String
Dim colcount As Integer
criteria = "widget1" ' Matching value
colcount = 10 ' Header columns count
For i = 1 To colcount
' Loop on 2nd row
If Cells(2, i).Value = criteria Then
' If string matched with a cell's value
If result Is Nothing Then
' if it's first match, set it as result column selection
Set result = Columns(i)
Else
' if it's not first match, add it to result selection
Set result = Union(result, Columns(i))
End If
End If
Next
' Select result seletion
If Not result Is Nothing Then
result.Select
End If
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
I have the following grid of data:
---------Header 1 Header 2 Header 3 Header 4
Row 1 x x x
Row 2 x x
Row 3 x
Row 4 x x x x
I then have a second sheet that looks like this:
Row 1 Row 2 Row 3 Row 4
I would like the second sheet to end up looking like this:
Row 1 Row 2 Row 3 Row 4
Header 1 Header 2 Header 3 Header 1
Header 3 Header 3 Header 2
Header 4 Header 3
. Header 4
Ignore that last period, I just used it to format it properly.
I've been playing with MATCH and INDEX for a couple hours and while I can get pieces of it, I can't seem to get it to all work together.
EDIT:
I use 'Header 1' and 'Row 1' as examples only. The actual data is text in Column A and Row 1, respectively. Also, since the source data will be modified, I'd prefer to have something that would automatically update the second sheet.
Here is one way to do it with a VBA function:
In the Developer Tab(*) Click on Visual Basic, then click on the "Insert" menu there and choose "Module" to insert a new module. Then paste in the Following code:
Option Explicit
Public Function GetHeaderMatchingRow(RowText As String, _
SearchRange As Range, _
iHdrNo As Integer) As String
Dim rng As Range
Set rng = SearchRange
Dim cel As Range
'Get the Row to scan
Dim i As Long, rowOff As Long
For i = 2 To rng.Rows.Count
Set cel = rng.Cells(i, 1)
If cel.Value = RowText Then
rowOff = i
Exit For
End If
Next i
'Now, scan horizontally for the iHdrNo'th non-blank cell
Dim cnt As Integer
For i = 2 To rng.Columns.Count
Set cel = rng.Cells(rowOff, i)
If Not CStr(cel.Value) = "" Then
cnt = cnt + 1
If cnt = iHdrNo Then
GetHeaderMatchingRow = rng.Cells(1, i).Value
Exit Function
End If
End If
Next i
GetHeaderMatchingRow = ""
End Function
Click on the "Debug" menu and select "Compile VBAProject".
Now go back to Excel and in your first sheet define a Named Range to cover all of your data in the grid. The Row names should be the first column in this range and the Header text should be the first row in it.
Now go to your second sheet and enter a formula like this in every output cell:
=GetHeaderMatchingRow(A$1, RowHeaderRange, 1)
Where the First parameter is the Row text that it will try to match in the first column of the range. I have "A$1" here because the in my test, my second sheet's column headers are also the Row-names in my first sheet, just like yours.
The second argument is the range to search (in this case, the Named Range we defined earlier), and the third argument is the count of the match that it is looking for (1st, 2nd, 3rd, etc.).
Note that the first and third parameters should change based on what column and row the output is for.
Does it have to use worksheet functions? It would be quite a bit simpler to create a macro to do it (I've made an example)
Edited the function to work with row headers in col a and column headers in row 1 and changed it to read from "Source" sheet and write the result to "Output" sheet
Public Sub Example()
Dim Output As Worksheet
Dim Sheet As Worksheet
Dim Row As Integer
Dim Column As Integer
Set Sheet = ThisWorkbook.Worksheets("Source")
Set Output = ThisWorkbook.Worksheets("Output")
Output.Cells.Clear ' Since were going to rebuild the whole thing, just nuke it.
For Row = Sheet.UsedRange.Rows(Sheet.UsedRange.Rows.Count).Row To 2 Step -1
Output.Cells(1, Row - 1).Value = Sheet.Cells(Row, 1).Value
For Column = Sheet.UsedRange.Columns(Sheet.UsedRange.Columns.Count).Column To 1 Step -1
If Not IsEmpty(Sheet.Cells(Row, Column)) Then
Sheet.Cells(1, Column).Copy
Output.Cells(2, Row - 1).Insert xlShiftDown
End If
Next Column
Next Row
End Sub
I had a look at doing it with worksheet functions and as others have said its going to be pretty tricky to do it without some vba mixed in there.
If you add this to a new module then you can access it as a workbook function. (not that this is the best way to do it, just fancied having a go)
'Return The Column Header of the Nth Non-Blank Cell on Specified Row
Public Function NonBlankByIndex(ByVal Row As Integer, ByVal Index As Integer) As Range
Dim Sheet As Worksheet
Dim Column As Integer
Dim Result As Range
Set Sheet = ThisWorkbook.Worksheets("Source") ' Change to your source sheet's name
Set Result = Nothing
Column = 2 ' Skip 1 as its the header
Do
If Column > Sheet.UsedRange.Columns(Sheet.UsedRange.Columns.Count).Column Then
Exit Do
End If
If Sheet.Cells(Row, Column) = "" Then
Column = Column + 1
Else
If Index = 1 Then
Set Result = Sheet.Cells(1, Column)
Exit Do
Else
Column = Column + 1
Index = Index - 1
End If
End If
Loop
Set NonBlankByIndex = Result
End Function
If you are happy with blanks in the listing try this in sheet2!A2:
=IF(INDEX(Sheet1!$B$2:$E$5,MATCH(A$1,Sheet1!$A$2:$A$5,0),ROW()-1)="x",INDEX(Sheet1!$B$1:$E$1,1,ROW()-1),"")
Just copy the formula over range A2:D5