After running the Userform_Initialize() event, there would be nothing populated in the listbox as shown below:
There should be 11 columns populating the listbox based on the excel table below:
The code ran:
Private Sub UserForm_Initialize()
Dim Total_rows_FoilProfile As Long
Dim row As Range, i As Long
Total_rows_FoilProfile = TotalRowsCount(ThisWorkbook.Name, "Foil Profile", "tblFoilProfile")
ReDim MyArr(0 To Total_rows_FoilProfile - 1)
For Each row In ThisWorkbook.Worksheets("Foil Profile").ListObjects("tblFoilProfile").Range.SpecialCells(xlCellTypeVisible).Rows
MyArr(i) = row.Value
i = i + 1
Next row
lbxFoilInfoDisplay.List = MyArr
frmFoilPanel.Show
The properties of the listbox:
You can populate each list row and then add the columns to it:
Option Explicit
Private Sub UserForm_Initialize()
Dim tblFoilProfile As ListObject
Set tblFoilProfile = ThisWorkbook.Worksheets("Foil Profile").ListObjects("tblFoilProfile")
Dim i As Long
lbxFoilInfoDisplay.Clear
Dim iListRow As Range
For Each iListRow In tblFoilProfile.DataBodyRange.SpecialCells(xlCellTypeVisible).Rows
With Me.lbxFoilInfoDisplay
.AddItem iListRow.Cells(1, 1).Value 'add first value (column 1)
Dim iCol As Long
For iCol = 2 To iListRow.Columns.Count 'add all other columns to that row
.list(i, iCol) = iListRow.Cells(1, iCol).Value '.Value for unformatted value or .Text to show it in the same format as in the cell
Next iCol
i = i + 1
End With
Next iListRow
End Sub
Note here is a nice guide how to work with list objects.
I need your help. It seems what I have written in code does not accomplish what I am trying to do here.
The objective would be to have 2 userform combo boxes one for the (floor) values which are manually added once [3,4,5] and the other combo boxes (offices) in which values are dynamically added based on the selection made in the floor selection box.
Let's say for example that if I chose the value [3] in my floor combo box that the office combo box would contain the following values:
A-01
A-02
A-03
A-04
A-05
A-06
A-07
A-08
I thought this code would work but it doesn't:
'Cells(row, col)
Private Sub floor_Change()
lRow = Sheets("Office Spaces").UsedRange.Rows.Count
With Sheets("Office Spaces")
For i = 2 To lRow
If .Cells(i, 1).Value = UserForm1.floor.Value Then
UserForm1.office.AddItem .Cells(i, 2).Value
End If
Next i
End With
End Sub
Here's what the data looks in my excel sheet:
'Cells(row, col)
Private Sub floor56_Change()
UserForm1.office.Clear
Dim sh
Dim rw
Set sh = Sheets("Office Spaces")
For Each rw In sh.Rows
If sh.Cells(rw.row, 1).Text = UserForm1.floor.Value Then
UserForm1.office.AddItem (sh.Cells(rw.row, 2).Value)
End If
Next rw
End Sub
or
Private Sub floor_Change()
If UserForm1.floor.Value <> "" Then
UserForm1.office.Clear
Dim ws
Set ws = ThisWorkbook.Worksheets("Office Spaces")
Dim rng
Set rng = ws.Range("A:A")
For Each cell In rng
If cell.Text = UserForm1.floor.Value Then
UserForm1.office.AddItem (cell.Offset(0, 1).Value)
End If
Next cell
End If
End Sub
My workbook has two sheets: one "Data" and one "Kiert". I solved to copy rows by specific attributes from "data" to "Kiert" with UserForm, but I added ti user form four textboxes (TextBox1, TextBox2 etc.) and I want to fill the database with constant values added in textbox with one command button in blank colums after pasted data.
I have additional textbox5, which indicates if the copy was succefull ("SIKERES"), this part works fine...
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim Drng As Range, c As Range
Dim i As Long
Dim lastRow As Long
Dim srcRange As Range, fillRange As Range
Set a = TextBox5
Set d = TextBox1
Set ws = Sheets("Data")
Set Drng = ws.Columns("A:A").SpecialCells(xlCellTypeConstants, 23)
For Each c In Drng.Cells
If c = ListBox1 Then
c.EntireRow.Copy
Sheets("Kiert").Range("A1000000").End(xlUp).Offset(1, 0)
Range("F:F" & lastRow).Formula = TextBox1.Value
If c.Value = ListBox1.Value Then
a.Value = "SIKERES"
End If
End If
Next c
End Sub
I insert here an example:
My main problem is I cannot describe a correct range and description of textboxes, and I don't know where I can put it in my code to run it properly.
I tried this:
For Each c In Drng.Cells
If c = ListBox1 Then
c.EntireRow.Copy Sheets("Summary").Range("A1048576").End(xlUp).Offset(1, 0)
Sheets("Kiert").Range("A:A" & lasrRow).Value = TextBox1.Text
If c.Value = ListBox1.Value Then
A.Value = "SIKERES"
End If
End If
Next c
...but its out of range.
It's not very clear what you are trying to do, but the code below will help you paste the values of your textboxes to the relevant column:
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim Drng As Range, c As Range
Dim i As Long
Dim NextFreeRow As Long
Dim srcRange As Range, fillRange As Range
Set Drng = Sheets("Data").Columns("A:A").SpecialCells(xlCellTypeConstants, 23)
For Each c In Drng.Cells 'loop through Column A on Sheet Data
If c = ListBox1.Value Then 'If the cells in Column A Sheet Data matches the selection on your Listbox1 then
NextFreeRow = Sheets("Kiert").Cells(Rows.Count, "A").End(xlUp).Row + 1 'Check the next free row on Sheet Kiert
c.EntireRow.Copy Desination:=Sheets("Kiert").Range("A" & NextFreeRow) 'Paste the entire row from Sheet Data to Sheet Kiert
Range("F" & NextFreeRow).Value = TextBox1.Text 'Copy the contents of TextBox1 to column F
'Add more lines like the one above to copy the values from your Textboxes to the relevant column
TextBox5.Text = "SIKERES"
End If
Next c
End Sub
I have data in Sheet2 as like below.
Actual Data
Then I manually apply filer to those data which looks like...
Filtered Data
I have a user form (UserForm1) and a list box (ListBox1) in the form. Also have a command button cmdFilteredData. So, I want to fill the listbox with filtered data only. I make below codes but it gives Type mismatch error.
Private Sub cmdFilteredData_Click()
Dim FilteredRange As Range
Set FilteredRange = Sheet2.Range("A1:C5").Rows.SpecialCells(xlCellTypeVisible)
With Me.ListBox1
.ColumnCount = 3
.MultiSelect = fmMultiSelectExtended
.RowSource = FilteredRange
End With
End Sub
Any help is hearty appreciated.
Since you are trying to populate the ListBox1 with values from filtered range, you have blank rows in the middle, this "messes" up the ListBox.
Instead, you can copy>>Paste the value to columns on the right (or another worksheet), use an array to populate these values, and then populate the ListBox1 with the array.
Code
Private Sub cmdFilteredData_Click()
Dim FilteredRange As Range
Dim myArr As Variant
Set FilteredRange = ThisWorkbook.Sheets("Sheet8").Range("A1:C5").SpecialCells(xlCellTypeVisible)
' copy filtered range to the columns on the right (if you want, you can add a "Dummy" sheet), to have the range continous
FilteredRange.Copy Range("Z1")
' populae the array with new range values (without blank rows in the middle)
myArr = Range("Z1").CurrentRegion
With Me.ListBox1
.ColumnCount = 3
.MultiSelect = fmMultiSelectExtended
.List = (myArr)
End With
End Sub
Alternative Function to - unreliable - SpecialCells(xlCellTypeVisible)
This answer intends to complete Shai Rado's appreciated solution, not to correct it.
Testing the above solution, however showed that using SpecialCells(xlCellTypeVisible) and/or reference to CurrentRegion might result in problems (even within OP's small range).
A possible work around function (esp. for udfs) is presented at SpecialCells(xlCellTypeVisible) not working in UDF.
Private Function VisibleCells(rng As Range) As Range
' Site: https://stackoverflow.com/questions/43234354/specialcellsxlcelltypevisible-not-working-in-udf
' Note: as proposed by CalumDA
Dim r As Range
For Each r In rng
If r.EntireRow.Hidden = False Then
If VisibleCells Is Nothing Then
Set VisibleCells = r
Else
Set VisibleCells = Union(VisibleCells, r)
End If
End If
Next r
End Function
Shai Rado's solution slightly modified (cf. above notes)
In any case the target range has to be cleared before copying and then better referenced without CurrentRegion, so that you get the wanted items only. These changes worked for me.
Option Explicit
Private Sub cmdFilteredData_Click()
Dim ws As Worksheet
Dim sRng As String
Dim FilteredRange As Range
Dim myArr As Variant
Dim n As Long
Set ws = ThisWorkbook.Worksheets("Filtered")
n = ws.Range("A" & ws.Rows.Count).End(xlUp).Row ' get last row
sRng = "A1:C" & n
' Set FilteredRange = ws.Range(sRng).SpecialCells(xlCellTypeVisible) ' << not reliable
Set FilteredRange = VisibleCells(ws.Range(sRng)) ' <<<< possible ALTERNATIVE
' clear target range in order to allow correct array fillings later !
ws.Range("Z:AAB").Value = ""
' copy filtered range to the columns on the right
FilteredRange.Copy ws.Range("Z1")
' populate the array with new range values (without blank rows in the middle)
' myArr = ws.Range("Z1").CurrentRegion ' sometimes unreliable, too
myArr = ws.Range("Z1:AAB" & ws.Range("Z" & ws.Rows.Count).End(xlUp).Row) ' <<< better than CurrentRegion
With Me.ListBox1
.ColumnCount = 3
.MultiSelect = fmMultiSelectExtended
.List = (myArr)
End With
End Sub
Links mentioned in cited post:
Microsoft - udf not working
ExcelForum - xlCelltypeVisible not working
MrExcel - SpecialCells not working
I was searching a lot for that but I couldn't fine any elegant solution for doing it without pasting data in the sheet. So I create my own function to convert visible cells of range into an array.
Maybe it's not the smartest way, but works just fine an quite fast.
Function createArrFromRng(rng As Range)
Dim sCellValues() As Variant
Dim col, row, colCount, RowCount As Integer
col = 0
row = 0
colCount = 0
RowCount = 0
On Error GoTo theEnd
Set rng = rng.SpecialCells(xlCellTypeVisible)
'get the columns and rows size
For Each cell In rng
If col < cell.Column Then
colCount = colCount + 1
Else
colCount = 1
End If
col = cell.Column
If row < cell.row Then
RowCount = RowCount + 1
End If
row = cell.row
Next cell
'set the array size
ReDim Preserve sCellValues(RowCount - 1, colCount - 1)
col = 0
row = 0
colCount = 0
RowCount = 0
'get the values and add to the array
For Each cell In rng
If col < cell.Column Then
colCount = colCount + 1
Else
colCount = 1
End If
col = cell.Column
'Debug.Print colCount
If row < cell.row Then
RowCount = RowCount + 1
End If
row = cell.row
sCellValues(RowCount - 1, colCount - 1) = cell.value
Next cell
theEnd:
createArrFromRng = sCellValues
End Function
I have excel table exported from another system. I need to upload this into a database and am looking for a way to normalize it.
Current structure:
customerid date1 date2 date3 ... date85
1 1/1 1/4 2/4
2 3/1
3 4/1 4/12
Need to convert to:
customerid date
1 1/1
1 1/4
1 2/4
2 3/1
3 4/1
3 4/12
I'm on a Mac and have excel 2016. I don't have any addons like power pivot.
You can use the Pivot Table Wizard for this (which is not an add-on, it's built-in Excel functionality):
Press Alt, D, P to open the Pivot Table Wizard
Select "Multiple Consolodation Ranges", and click Next
Select "I will create the page fields", and click Next
With the cursor in the "Range" textbox, select your range of data, including row headers (in your example, I believe that would be A1:CH4), and click Add, then click Next
Select "New worksheet", and click Finish
In the new worksheet that is generated, double-click in the bottom-right cell (the "Grand Total" cell). This will open a second new worksheet containing your normalized data.
To remove blank values in the second new worksheet, click the filter icon in the "Value" column, and de-select the "(Blanks)" checkbox
Copy the resulting data to the clipboard, and paste wherever it is needed.
Assuming customerid is in A1, please try (I haven't!) in Row 2 in a column:
=OFFSET(A$2,INT((ROW()-2)/85),)
and in another column:
=OFFSET(B$2,INT(ROW()/85),MOD(ROW()-2,85),)
Copy down to suit, select the formulae cells, Copy, Paste Special..., Values over the top and then Filter to remove zeros in 'another' column.
Beware if doing this all in the one sheet as deleting rows might also delete some of your source data.
Add labels.
Here is a VBA method that should work quite rapidly, even on a large data base.
Note that you have to rename the class module as noted in that module.
Also note that you may have to rename wsSrc and wsRes -- the worksheets with your source data and where you want the results to go.
There is also an area near the end of the regular module where I do some rudimentary formatting. You can certainly adjust that to pretty things up, if you need to.
Class Module
Option Explicit
'Rename cCustDTS
Private pID As String
Private pDT As Date
Private pDTs As Collection
Private Sub Class_Initialize()
Set pDTs = New Collection
End Sub
Public Property Get ID() As String
ID = pID
End Property
Public Property Let ID(Value As String)
pID = Value
End Property
Public Property Get DT() As Date
DT = pDT
End Property
Public Property Let DT(Value As Date)
pDT = Value
End Property
Public Property Get DTs() As Collection
Set DTs = pDTs
End Property
Public Function ADDdt(Value As Date)
pDTs.Add Value
End Function
Regular Module
Option Explicit
Sub NormalizeDates()
Dim vSrc As Variant, vRes As Variant
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim cCD As cCustDTS, colCD As Collection
Dim I As Long, J As Long, LineCount As Long
Dim LastRow As Long, LastCol As Long
Dim V As Variant, W As Variant
'Set Source and Results Worksheets and Ranges
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
Set rRes = wsRes.Cells(1, 1)
'Get Source Data
With wsSrc
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
vSrc = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With
'Collect and organize the data
Set colCD = New Collection
For I = 2 To UBound(vSrc, 1) 'Skip the first row
Set cCD = New cCustDTS
With cCD
.ID = vSrc(I, 1)
For J = 2 To UBound(vSrc, 2)
If IsDate(vSrc(I, J)) Then
.DT = vSrc(I, J)
.ADDdt .DT
End If
Next J
colCD.Add cCD
LineCount = LineCount + .DTs.Count
End With
Next I
'Organize the data for output
ReDim vRes(0 To LineCount, 1 To 2)
vRes(0, 1) = "Customer ID"
vRes(0, 2) = "Date"
I = 0
For Each V In colCD
For Each W In V.DTs
I = I + 1
vRes(I, 1) = V.ID
vRes(I, 2) = W
Next W
Next V
'Write to the output sheet and format
Set rRes = rRes.Resize(rowsize:=UBound(vRes, 1) + 1, columnsize:=UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
With .Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
With .Columns(2)
.NumberFormat = "m/d"
End With
.EntireColumn.AutoFit
.Columns(2).ColumnWidth = .Columns(2).ColumnWidth * 2
End With
End Sub
Here's what I came up with, I hope VBA isn't that much different on Mac then it is on PC, otherwise this may not work.
The code is fairly commented, although feel free to ask if there are questions.
'Helper function to find the last Column
Public Function getLastColumn(strSheet, strColum) As Integer
Dim rng As Range
Set rng = Sheets(strSheet).Cells.Find(What:="*", _
After:=Sheets(strSheet).Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If rng Is Nothing Then
getLastColumn = 1
Else
getLastColumn = rng.Column
End If
End Function
'Helper function to find the lastRow
Public Function getLastRow(strSheet, strColum) As Long
Dim rng As Range: Set rng = Worksheets(strSheet).Range(strColum & "1")
getLastRow = Worksheets(strSheet).Cells(Rows.Count, rng.Column).End(xlUp).row
End Function
Public Sub Normalize_Table()
Dim LastRow As Long: LastRow = getLastRow("Sheet1", "A") ' First Parameter is the Sheet Name,
' Second is the column you want to count
Dim LastColumn As Integer: LastColumn = getLastColumn("Sheet1", "A")
Dim RowCounter As Long: RowCounter = 1 ' Starting Row
Dim RowID As Variant ' RowID, basically this is the repeated Column 1 value
Dim row As Object
Dim col As Object
Dim rng As Range: Set rng = Sheets("Sheet1").Range(Sheets("Sheet1").Cells(1, 1), _
Sheets("Sheet1").Cells(LastRow, LastColumn)) ' Get the range you want to Normalize to another sheet/range
'Iterate the range, go through each row, and each column
'Making a new row for each column value, only update the value
'of the first column when a start a new row
For Each row In rng.Rows
RowID = rng.Cells(row.row, 1)
For Each col In rng.Columns
'Assuming you want to add this to a new sheet, Let's say "Sheet2"
Sheets("Sheet2").Cells(RowCounter, 1) = RowID
If col.Column > 1 Then
Sheets("Sheet2").Cells(RowCounter, 2) = rng(row.row, col.Column)
RowCounter = RowCounter + 1
End If
Next
Next
End Sub