I am trying to figure out the proper code for populating a listbox based on a selection from a second listbox. I will explain my question the best I can. I have one worksheet with two columns populated like this.
(COLUMN A) (COLUMN B)
PART NUMBER: LOCATION:
PART A LOC1,LOC7,LOC12,LOC21
PART B LOC2,LOC8,LOC13,LOC22
PART C LOC6,LOC9,LOC18,LOC20
I want to be able to populate ListBox1 with the "PART NUMBER" column and when I click on "PART A" I get just a list of items for location from (Column B) in ListBox2. I hope this makes sense and someone can help me out. Thank you in advance.
To populate my ListBox:
Dim rngName As Range
Dim ws As Worksheet
Dim i As Integer
Set ws = Worksheets("Sheet2")
For i = 1 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row Step 1
If ws.Cells(i, 1).Value <> vbNullString Then Me.LstPartNum.AddItem ws.Cells(i, 1).Value
Next i
To Test populate and split by commas:
UserForm1.LstPartNum.List = Split("LOC1,LOC7,LOC12,LOC21", ",")
In the change event of the part number combobox do something like this.
Dim ws As Excel.Worksheet
Dim lRow As Long
Set ws = Worksheets("Sheet2")
lRow = 1
'Loop through the rows
Do While lRow <= ws.UsedRange.Rows.count
'Check if Column A has the value of the selected part number.
If ws.Range("A" & lRow).Value = LstPartNum.Text Then
UserForm1.LstLocation.Clear
'Load the locations
UserForm1.LstLocation.List = Split(ws.Range("B" & lRow).Value, ",")
Exit Do
End If
lRow = lRow + 1
Loop
If your UserForm1.LstPartNum.List = Split() does not work to load the list, here is code to loop the split array.
Dim szLocs() As String
Dim i as integer
szLocs= Split(ws.Range("B" & lRow).Value, ",")
i = 0
'Loop though each token
Do While i <= UBound(szPieces)
UserForm1.LstPartNum.Additem szPieces(i)
i = i + 1
Loop
Related
I am brand-new to VBA.
I have two worksheets in the same workbook. The first worksheet, shStudentInfo, contains all of the information for each of my students, one row per StudentID (B4 in the code). The second worksheet, shSchedData, contains their schedules where there may be 0-14 rows per StudentID, depending on how many courses each student is taking.
I am attempting to use a loop and VLOOKUP with a dynamic range to extract the course name from each row of shSchedData and copy it to the appropriate cell in shStudentInfo, then move down one row. Currently I've hardcoded cell "CO4" as the appropriate cell although I will also need to make that reference move one cell to the right for each pass through the loop.
Here is my inelegant code:
Option Explicit
Dim MyRow As Long
Sub StudentSchedules()
Dim EndRow As Long
Dim MyRng As Range
shSchedData.Activate
'hard code first row of data set
MyRow = 3
'dynamic code last row of data set
EndRow = shSchedData.Range("A1048575").End(xlUp).Row
'create a dynamic range, a single row from shSchedData
Set MyRng = ActiveSheet.Range(Cells(MyRow, 1), Cells(MyRow, 9))
'Loop through entire data set one line at a time
Do While MyRow <= EndRow
shSchedData.Select
MyRng = ActiveSheet.Range(Cells(MyRow,1),Cells(MyRow,9))
shStudentInfo.Select
'Import course name from shSchedData worksheet
Range("CO4").Select
ActiveCell.Clear
ActiveCell.Formula = "=VLOOKUP(B4,'Schedule Data'!& MyRng,6,0)"
'The above line results in a #NAME? error in CO4 of shStudentInfo
'Also tried:
'ActiveCell.Formula = "=VLOOKUP(B4,'Schedule Data'!& MyRng.Address,6,0)"
'increment counter
MyRow = MyRow + 1
Loop
End Sub
The following rewrite will get your code working to the extent that its purpose can be determined.
The VLOOKUP formula does not appear correct and in any event, there might be a better method of retrieving the data. However, I cannot determine your end purpose from your narrative or code. Sample data together with expected results would help.
Option Explicit
'I see no reason to put this here
'dim myRow As Long
Sub StudentSchedules()
Dim myRow, endRow As Long, myRng As Range
'no need to activate, just With ... End With block it
With shSchedData
'assigned a strarting value
myRow = 3
'dynamic code last row of data set
endRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop through entire data set one line at a time
Do While myRow <= endRow
'create a dynamic range, a single row from shSchedData
Set myRng = .Range(.Cells(myRow, 1), .Cells(myRow, 9))
'Import course name from shSchedData worksheet
shStudentInfo.Range("CO4").Offset(0, myRow - 3).Formula = _
"=VLOOKUP(B4, " & myRng.Address(external:=True) & ", 6, false)"
'increment counter
myRow = myRow + 1
Loop
End With
End Sub
I came up with this, see if it fits you
Dim a As Double
Dim b As Double
Dim ml As Worksheet
Dim arrayrng As Variant
Dim i As Integer
Dim x As String
Dim y As String
Set ml = Worksheets("Master Data")
a = ml.Cells(Rows.Count, 11).End(xlUp).Row
b = ml.Cells(Rows.Count, 1).End(xlUp).Row
For i = a To b - 1
a = ml.Cells(Rows.Count, 11).End(xlUp).Row
b = ml.Cells(Rows.Count, 1).End(xlUp).Row
arrayrng = "E" & a + 1
x = "=VLOOKUP(" & arrayrng
y = ",'Data Base'!I:J,2,0)"enter code here
Range("K" & a + 1) = x + y
Next
I need to use VBA code to populate a list of filtered blank cells. I decided to make a picture with small example to explain it easier. Column D should be populated with names from col A repeating until each ID has a name.
I have absolutely no idea how to loop it to make it work - it's mind boggling! I have been searching the web for hours so I am now asking for help. Please note that column C and D are filtered with criteria blanks for column D.
Here is working code to populate blank cells of a filtered list with the same 3 names alternating.
Sub Macro1()
Dim last As Long
Dim counter As Integer
Dim nameRange As Range
Dim cell As Range
last = Range("A2").End(xlDown).Row
Set nameRange = Range("D2:D" & last).SpecialCells(xlCellTypeVisible)
counter = 1
For Each cell In nameRange
If counter = 1 Then
cell.Value = "Carrie"
counter = counter + 1
ElseIf counter = 2 Then
cell.Value = "Lisa"
counter = counter + 1
Else
cell.Value = "Bob"
counter = 1
End If
Next
End Sub
thanks for everyone's input - Hopefully, this will help someone else in the future.
This will do it without the need of filtering the data.
Sub foo()
Dim ws As Worksheet
Dim lastrowa As Long
Dim lastrowd As Long
Dim counta As Long
Dim rng As Range
counta = 2 'First row of name list in column A
Set ws = Sheets("Sheet1")
With ws
lastrowa = .Range("A" & .Rows.Count).End(xlUp).Row
lastrowd = .Range("D" & .Rows.Count).End(xlUp).Row
For Each rng In .Range(.Cells(2, 5), .Cells(lastrowd, 5))
If rng.Value = "" Then
rng.Value = .Cells(counta, 1).Value
If counta = lastrowa Then
counta = 2
Else
counta = counta + 1
End If
End If
Next rng
End With
End Sub
Range("D2:D4").Value = Range("A2:A4").Value
Range("D2:D4").AutoFill Destination:=Range("D2:D11")
If you don't know where column C ends that is easy enough to work out. Something like
Range("D2:D4").Value = Range("A2:A4").Value
Range("D2:D4").AutoFill Destination:=Range(Range("D2"), _
Range("C2").End(xlDown).Cells(1, 2))
If you don't know how far the data extends in column A:
Dim last As Integer
last = Range("A2").End(xlDown).Row
Range("D2:D" & last).Value = Range("A2:A" & last).Value
Range("D2:D" & last).AutoFill Destination:=Range(Range("D2"), _
Range("C2").End(xlDown).Cells(1, 2))
My example doesn't work perfectly, or even well... Its late :)
Create a named range that encapsulates all your "names" (called namesRange in my example).
In your "assigned" column put the following formula:
=INDEX(namesList,ROW()-((INT(ROW()/ROWS(namesList))*ROWS(namesList))),1)
Update...
Thought about it, and remembered how to excel a little more.. The following is what I was trying to do in my first example.
=INDEX(namesList,MOD(ROW()-1,ROWS(namesList)-1)+1,1)
I have a workbook of ten sheets. In sheet 1, I want to list out sheet names (sheets 3 thru 10), column heading values in the sheet (columns 8 and beyond only) and for that column the number of cells that have data in it.
My code works for two of these three requirements. On my sheet 1 (named: SheetName Columns) I get the Sheet Names in column A and Column Heading in column B, however not having any luck getting that sheet/columns number of data rows.
On my sheet 1, column A gets duplicated per number of columns after column 7 on that sheet and that is fine.
Sub ListColumnHeadings()
Dim cNbrs As Long, i As Integer, tr As Long, tc As Long, wst As Worksheet
Dim charList(300, 300) As String
Dim ws As Worksheet, OutputRow As Long
Dim myRange As Range
Dim NumRows As Integer
Dim colNbr As Range
Set shSkip1 = ThisWorkbook.Sheets("SheetName Record Cnt")
Set shList = ThisWorkbook.Sheets("SheetName Columns")
OutputRow = 1
On Error Resume Next
For Each ws In Worksheets
If ws.Name <> shList.Name And ws.Name <> shSkip1.Name Then
cNbrs = ws.Range("A1").CurrentRegion.Columns.Count
For i = 8 To cNbrs
shList.Cells(OutputRow, "A").Value = ws.Name
shList.Cells(OutputRow, "B").Value = ws.Cells(1, i)
Set myRange = ws.Columns(i).Select
NumRows = ws.Application.WorksheetFunction.CountA(myRange)
If NumRows > 0 Then
shList.Cells(OutputRow, "C").Value = NumRows
End If
OutputRow = OutputRow + 1
Next i
End If
Next ws
End Sub
It's because of your use of Set myRange... You don't need to .Select it. Just change that line to Set myRange = ws.Columns(i)
If you want to leave .Select, then the next line should be
NumRows = ws.application.worksheetfunction.counta(selection), but it is highly recommended you avoid using .Select, this is just for your info.
This is my first attempt at VBA, so I apologize for my ignorance. The situation is as follows: I have a spreadsheet that consists of 4 columns and 629 rows. When I am trying to do is iterate through the 4 cells in each row and check for a blank cell. If there is a row that contains a blank cell, I want to cut it from Sheet1 and paste it into the first available row in Sheet2.
(Ideally the number of columns AND the number of rows is dynamic based on each spreadsheet, but I have no idea how to iterate through rows and columns dynamically)
Sub Macro1()
'
' Macro1 Macro
' Move lines containing empty cells to sheet 2
'
' Keyboard Shortcut: Ctrl+r
'
Dim Continue As Boolean
Dim FirstRow As Long
Dim CurrentRow As Long
Dim LastRow As Long
Dim EmptySheetCount As Long
Dim Counter As Integer
'Initialize Variables
LContinue = True
FirstRow = 2
CurrentRow = FirstRow
LastRow = 629
EmptySheetCount = 1
'Sheets(Sheet1).Select
'Iterate through cells in each row until an empty one is found
While (CurrentRow <= LastRow)
For Counter = 1 To 4
If Sheet1.Cells(CurrentRow, Counter).Value = "" Then
Sheet1.Cells(CurrentRow).EntireRow.Cut Sheet2.Cells(EmptySheetCount, "A")
EmptySheetCount = EmptySheetCount + 1
Counter = 1
CurrentRow = CurrentRow + 1
GoTo BREAK
Else
Counter = Counter + 1
End If
Counter = 1
BREAK:
Next
Wend
End Sub
When I run it, I typically get an error around the Sheet1.Cells(CurrentRow, Counter).Value = "" area, so I know I'm referencing sheets incorrectly. I've tried Sheets(Sheet1), Worksheets("Sheet1") and nothing seems to be working. When I do change to Worksheets("Sheet1"), however, it runs and just freezes Excel.
I know I'm doing multiple things wrong, I just know way too little to know what.
Thanks a lot in advance. And sorry for the crap formatting.
There are a few things wrong with your code so rather than go through them individually here is a basic looping version that does what you're after.
Sub moveData()
Dim wksData As Worksheet
Dim wksDestination As Worksheet
Dim lastColumn As Integer
Dim lastRow As Integer
Dim destinationRow As Integer
Set wksData = Worksheets("Sheet1")
Set wksDestination = Worksheets("Sheet2")
destinationRow = 1
lastColumn = wksData.Range("XFD1").End(xlToLeft).Column
lastRow = wksData.Range("A1048576").End(xlUp).Row
For i = lastRow To 1 Step -1 'go 'up' the worksheet to handle 'deletes'
For j = 1 To lastColumn
If wksData.Cells(i, j).Value = "" Then 'check for a blank cell in the current row
'if there is a blank, cut the row
wksData.Activate
wksData.Range(Cells(i, 1), Cells(i, lastColumn)).Cut
wksDestination.Activate
wksDestination.Range(Cells(destinationRow, 1), Cells(destinationRow, lastColumn)).Select
ActiveSheet.Paste
'If required this code will delete the 'cut' row
wksData.Rows(i).Delete shift:=xlUp
'increment the output row
destinationRow = destinationRow + 1
Exit For 'no need to carry on with this loop as a blank was already found
End If
Next j
Next i
set wksData = Nothing
set wksDestination = Nothing
End Sub
There are other ways that will achieve the same outcome but this should give you and idea of how to use loops, sheets, ranges, etc.
The lastColumn and lastRow variables will find the the last column/row of data in the given columns/rows (i.e, in my code it finds the last column of data in row 1, and the last row of data in column A).
Also, you should get into the habit of debugging and stepping through code to identify errors and see exactly what each line is doing (this will also help you learn too).
You might find this of use.
It uses an array variable to store the values of the cells in the row to be moved. It does not use cut and paste, so only transfer the data values, and the code does not require activation of the required sheets.
The destination rows are in the same order as the rows on the original sheet.
The method used to find the last cell used in the row and column is more elegant than other answers given.
Option Explicit
Public Sub test_moveData()
Dim wksData As Worksheet
Dim wksDestination As Worksheet
Set wksData = shtSheet1 ' Use the Codename "shtSheet1" for the worksheet. ie the value of the sheet property that is displayed as "(Name)"
Set wksDestination = shtSheet2
moveData wksData, wksDestination
End Sub
Public Sub moveData(wksData As Worksheet, wksDestination As Worksheet)
Dim ilastColumn As Integer
Dim ilastRow As Integer
Dim iRow As Long
Dim iColumn As Long
Dim iDestinationRowNumber As Integer
Dim MyArray() As Variant
Dim rngRowsToDelete As Range
iDestinationRowNumber = 1
ilastColumn = wksData.Cells(1, wksData.Columns.Count).End(xlToLeft).Column
ilastRow = wksData.Cells(wksData.Rows.Count, 1).End(xlUp).Row
ReDim MyArray(1, ilastColumn)
Set rngRowsToDelete = Nothing
For iRow = 1 To ilastRow Step 1 'No need to go 'up' the worksheet to handle 'deletes'
For iColumn = 1 To ilastColumn
If wksData.Cells(iRow, iColumn).Value = "" Then 'check for a blank cell in the current row
MyArray = wksData.Range(wksData.Cells(iRow, 1), wksData.Cells(iRow, ilastColumn)).Value
wksDestination.Range(wksDestination.Cells(iDestinationRowNumber, 1),
wksDestination.Cells(iDestinationRowNumber, ilastColumn) _
).Value = MyArray
'Store the rows to be deleted
If rngRowsToDelete Is Nothing Then
Set rngRowsToDelete = wksData.Rows(iRow)
Else
Set rngRowsToDelete = Union(rngRowsToDelete, wksData.Rows(iRow))
End If
'increment the output row
iDestinationRowNumber = iDestinationRowNumber + 1
Exit For 'no need to carry on with this loop as a blank was already found
End If
Next iColumn
Next iRow
If Not rngRowsToDelete Is Nothing Then
rngRowsToDelete.EntireRow.Delete shift:=xlUp
End If
Set rngRowsToDelete = Nothing
Set wksData = Nothing
Set wksDestination = Nothing
End Sub
' enjoy
I realize there are a few different similar ideas on here. But I need help with this simple compare function.
My goal is to compare two different cells and if they are the same, replace it with its full non-abbreviated name.
Thank you for your time!!!
I.E
Sheet1 Sheet2
Column H Column A Column B
Dept Dept Department
This is what I have (Yes simple), but the cell H is not updating to the non-abbreviation:
Sub updateDeptNames()
'Format user ID from the email column
Dim ws As Worksheet, ws2 As Worksheet
Dim LastRow As Long, i As Long
Dim tmpArray() As String, tempDept As String
Set ws = ActiveWorkbook.Sheets("Student_Travel_DB") '--> This is the relevant sheet
Set ws2 = ActiveWorkbook.Sheets("gokoutd") '--> This is the relevant sheet
LastRow = 1000 ''Bug finding the last row, had to hard code it
For i = 2 To LastRow 'Iterate through all the rows in the sheet
For j = 2 To 112
tempDept = ws2.Range("A" & j).Value
If ws.Range("H" & i).Value = tempDept Then
ws.Range("H" & i) = ws2.Range("B" & j).Value
End If
Next j
Next i
End Sub
You can more easily use VLOOKUP either on your worksheet or with VBA:
Sub GetFullName()
Dim cl As Range, data As Range, lookUpRng As Range
Set data = Worksheets("Student_Travel_DB").Range("A1:A10")
Set lookUpRng = Worksheets("gokoutd").Range("A1:B10")
On Error Resume Next
For Each cl In data
cl = WorksheetFunction.VLookup(cl, lookUpRng, 2, False)
Next cl
End Sub
You'll need to change your range references.