I have a workbook where each branch office has it's own tab. Each tab has row headers of available dates for interviews, and the column headers for the available times. It is screencapped below:
From there I'm using a user form to collect the branch name from a dropdown (populated by looping through names of the sheets), the available dates (getting the days on the identified sheet), then the blank times for the given dates.
For some reason, every time a date is selected, it's setting the date cell to "" or blank. Can anyone verify my syntax if right? I can't tell where it might be setting it to blank... Thanks!
Option Explicit
Public Sub UserForm_Initialize()Dim sht As Worksheet
'clear form
BranchBox.Value = ""
DateBox.Value = ""
TimeBox.Value = ""
'populate sheet names from each branch
For Each sht In ActiveWorkbook.Sheets
Me.BranchBox.AddItem sht.Name
Next sht
End Sub
Public Sub BranchBox_Change()
'populate dates
Me.DateBox.List = Worksheets(BranchBox.Value).Range("A2:A31").Value
End Sub
Public Sub DateBox_Change()
Dim dateSel As String
Dim branch As String
Dim sht As Worksheet
Dim cel As Range
Dim matchingHeader As Range
branch = BranchBox.Value
Set sht = ActiveWorkbook.Worksheets(branch)
dateSel = DateBox.Value
'Get Row to scan
Dim i As Long, rowOff As Long
For i = 2 To sht.Rows.Count
Set cel = sht.Cells(i, 1)
If cel.Value = dateSel Then
rowOff = i
Exit For
End If
Next i
'Scan selected row for blank cells
Dim cnt As Integer
For i = 2 To sht.Columns.Count
cel = sht.Cells(rowOff, i)
If CStr(cel.Value) = "" Then
Set matchingHeader = sht.Cells(1, i)
TimeBox.AddItem matchingHeader.Value
End If
Next i
Me.TimeBox.AddItem ("No Appointments Available")
End Sub
Your line
cel = sht.Cells(rowOff, i)
is implicitly
cel.Value = sht.Cells(rowOff, i).Value
I believe you intended the line to be
Set cel = sht.Cells(rowOff, i)
Related
I have got an excel workbook, it has 5 static tabs and more tabs can be created using a template tab.
In each tab there is a certain field or a range that is mandatory to be filled out also in the new created tabs (might be up to 60).
My question is how can I go about seeing in, lets say in mainsheet, a summary which shows me:
Which tab has missing fields
Which fields is missing (an address of a cell)
I tried naming the range "MyRange" and counting if the cells are non blank.
But this will not work for the newly created sheets.
I also tried a conditional formatting but again this will not give me a summary.
In the meantime I also bumped into a sort of solution but this is also not the thing I am looking for:
Sub listEmptyCells()
Dim emptyAddresses() As String
Dim i As Long
Dim ws As Worksheet
Dim rng As Range
Set ws = Sheets("1.Data Source") ' CHANGE AS NECESSARY
Set rng = ws.Range("B30:B32")
If WorksheetFunction.CountBlank(rng) = 0 Then
MsgBox ("No empty cells in the range")
Exit Sub
End If
emptyAddresses() = Split(rng.SpecialCells(xlCellTypeBlanks).Address, ",")
For i = LBound(emptyAddresses) To UBound(emptyAddresses)
ws.Cells(i + 1, 2).Value = emptyAddresses(i)
Next i
End Sub
Your help and guidance here would be highly appreciated
All the best
Jacek
Here's one approach:
Sub listEmptyCells()
Const CHECK_RANGE As String = "B30:B32" 'range to locate empty cells in
Dim i As Long, r As Long, rngCheck As Range, rngEmpty As Range
Dim ws As Worksheet, wb As Workbook, wsSummary As Worksheet
Dim rwSummary As Range, s As String, c As Range
Set wb = ThisWorkbook
Set wsSummary = wb.Worksheets("Summary")
Set rwSummary = wsSummary.Range("A2:B2") 'first row of results
rwSummary.Resize(wb.Worksheets.Count).Clear 'remove previous results
For i = 1 To wb.Worksheets.Count
Set ws = wb.Worksheets(i)
If ws.Name <> wsSummary.Name Then 'exclude specific sheet(s)
s = ""
Set rngEmpty = Nothing
'which range to check - special case or use default?
Select Case ws.Name
Case "Sheet One": Set rngCheck = ws.Range("A1:A10")
Case "Sheet Two": Set rngCheck = ws.Range("G34:G56,H10")
Case Else: Set rngCheck = ws.Range(CHECK_RANGE) 'default range
End Select
'loop cells in check range
For Each c In rngCheck.Cells
If Len(c.Value) = 0 Then
If rngEmpty Is Nothing Then
Set rngEmpty = c
Else
Set rngEmpty = Application.Union(rngEmpty, c)
End If
End If
Next c
If Not rngEmpty Is Nothing Then
s = rngEmpty.Count & " required cell(s) not filled:" & _
rngEmpty.Address(False, False)
End If
With rwSummary 'record results
.Cells(1).Value = ws.Name
.Cells(2).Value = IIf(s <> "", s, "OK")
.Font.Color = IIf(s <> "", vbRed, vbGreen)
End With
Set rwSummary = rwSummary.Offset(1, 0) 'next summary row
End If
Next i
End Sub
I have a workbook with two worksheets.
The first sheet contains a list of email adresses.
The second sheet contains a list of email adresses of which some match the ones in first sheet and some may not
I added a button and some code (see below). When i hit the button excel looks in sheet2 and compares it with the email addresses in sheet1 ... if it finds equal email-addresses it adds the found email address & the "allowed"-state behind the existing address in sheet1.
This is working fine:
Private Sub CommandButton1_Click()
Call lookup
End Sub
Sub lookup()
Dim TotalRows As Long
Dim rng As Range
Dim i As Long
'Copy lookup values from sheet1 to sheet3
Sheets("Tabelle1").Select
TotalRows = ActiveSheet.UsedRange.Rows.Count
For i = 1 To TotalRows
'Search for the value on sheet2
Set rng = Sheets("Tabelle2").UsedRange.Find(Cells(i, 1).Value)
'If it is found put its value on the destination sheet
If Not rng Is Nothing Then
Cells(i, 2).Value = rng.Value
Cells(i, 3).Value = "Allowed"
End If
Next
End Sub
But now I want to have the button in one "trigger.xlsm"-file and the data is in two different workbooks. ...so i have one button to copy the compare data from workbook2 to sheet2 in workbook1.... this works well!
But the rest of the code that compares and writes the equal mail-addresses in workbook1 - sheet1 does not... every line is filled with "allowed"-state.
I tried with this code which gives the above result:
Private Sub CommandButton1_Click()
Workbooks.Open "C:\Users\DEJP0050\Documents\testvon.xlsx"
Workbooks.Open "C:\Users\DEJP0050\Documents\testnach.xlsm"
Workbooks("testvon.xlsx").Sheets("Tabelle1").Range("A:A").Copy _
Workbooks("testnach.xlsm").Sheets("Tabelle2").Range("A:A")
Workbooks("testvon.xlsx").Close SaveChanges:=True
Workbooks("testnach.xlsm").Close SaveChanges:=True
End Sub
Private Sub CommandButton2_Click()
Call lookup
End Sub
Sub lookup()
Dim TotalRows As Long
Dim rng As Range
Dim i As Long
Dim wb1 As Excel.Workbook
Set wb1 = Workbooks.Open("C:\Users\DEJP0050\Documents\testnach.xlsx")
Dim ws11 As Worksheet
Set ws11 = wb1.Sheets("Tabelle1")
Dim ws12 As Worksheet
Set ws12 = wb1.Sheets("Tabelle2")
'Copy lookup values from sheet1 to sheet3
'ws11.Select
TotalRows = ws11.UsedRange.Rows.Count
'Range("A1:A" & TotalRows).Copy
Destination:=Sheets("Tabelle3").Range("A1")
'Go to the destination sheet
'Sheets("Tabelle3").Select
For i = 1 To TotalRows
'Search for the value on sheet2
Set rng = ws12.UsedRange.Find(Cells(i, 1).Value)
'If it is found put its value on the destination sheet
If Not rng Is Nothing Then
ws11.Cells(i, 2).Value = rng.Value
'Cells(i, 2).Value = "Allowed"
ws11.Cells(i, 3).Value = "Allowed"
End If
Next
Workbooks("testnach.xlsx").Close SaveChanges:=True
End Sub
Why does it work when the button is within the same workbook, but doesnt work when the button is in another workbook?
Maybe you need to change
Sheets("Tabelle1").Select
to
activeworkbook.Sheets("Tabelle1").Select
AND
TotalRows = ActiveSheet.UsedRange.Rows.Count
to
TotalRows = activeworkbook.ActiveSheet.UsedRange.Rows.Count
AND
Set rng = Sheets("Tabelle2").UsedRange.Find(Cells(i, 1).Value)
to
Set rng = activeworkbook.Sheets("Tabelle2").UsedRange.Find(activeworkbook.Sheets("Tabelle2").Cells(i, 1).Value)
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 am trying to delete duplicate values in a temporary list based on a value in a combobox. The code below loops through individual rows to check whether a value matches. It is slow.
Dim ws As Worksheet
Dim i As Long
Set ws = Sheets("TempList3")
On Error Resume Next
For i = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
If Cells(i, 2) <> Sheets("Sheet1").ComboBox2.Value Then
ws.Rows(i).EntireRow.Delete
End If
Next
Is there a way to evaluate the entire column's values against the combobox's value once and then delete all rows on a worksheet. Or perhaps there is a better way?
I used a looping Find function, it deletes the row where the value was found and then it searches again and deletes the next row it finds until it can no longer find the Combo value on the sheet:
Sub find_cell()
Dim find_cell As Range
Set ws = Sheets("TempList3")
stop_loop = False
Do Until stop_loop = True
Set find_cell = ws.Cells.Find(What:=Sheets("Sheet1").ComboBox2.Value, LookAt:=xlWhole)
If Not find_cell Is Nothing Then
ws.Rows(find_cell.Row).EntireRow.Delete
Else
stop_loop = True
End If
Loop
End Sub
Not knowing how many rows you are talking about, I used 10 thousand for my example codes. here are two examples, try the both and see what works best for you.
You can run through the column and unionize the range found, then delete the rows, for example.
See here for example workbook
Sub UnIonRng()
Dim FrstRng As Range
Dim UnIonRng As Range
Dim c As Range, s As String
s = Sheets("Sheet1").ComboBox2
Set FrstRng = Range("B:B").SpecialCells(xlCellTypeConstants, 23)
For Each c In FrstRng.Cells
If c = s Then
If Not UnIonRng Is Nothing Then
Set UnIonRng = Union(UnIonRng, c) 'adds to the range
'MsgBox UnionRng.Address 'remove later
Else
Set UnIonRng = c
End If
End If
Next c
UnIonRng.EntireRow.Delete
End Sub
Or you can try to filter the column B and delete the rows that way:
Sub FilterDeleteRow()
Dim ws As Worksheet
Dim LstRw As Long, Rng As Range, s As String, x
Set ws = Sheets("TempList3")
s = Sheets("Sheet1").ComboBox2
Application.ScreenUpdating = 0
With ws
LstRw = .Cells(.Rows.Count, "B").End(xlUp).Row
x = Application.WorksheetFunction.CountIf(.Range("B:B"), s)
If x > 0 Then
Columns("B:B").AutoFilter Field:=1, Criteria1:=s
Set Rng = .Range("B2:B" & LstRw).SpecialCells(xlCellTypeVisible)
Rng.EntireRow.Delete
.AutoFilterMode = 0
Else: MsgBox "Not Found"
End If
End With
End Sub
Sub CheckBox7_Click()
Dim cBox As CheckBox
Dim LRow As Integer
Dim LRange As String
LName = Application.Caller
Set cBox = ActiveSheet.CheckBoxes(LName)
'Find row that checkbox resides in
LRow = cBox.TopLeftCell.Row
LRange = "B" & CStr(LRow)
'Change text in column b, if checkbox is checked
If cBox.Value > 0 Then
ActiveSheet.Range(LRange).Value = "3300-0401"
'Clear text in column b, if checkbox is unchecked
Else
ActiveSheet.Range(LRange).Value = Null
End If
End Sub
I need value 3300-0401 to be entered in the first available cell beginning at b15 through b40. Also, where would this date be entered in the string?
Thanks, Jean
You can use the following to write to the first blank cell in the range B15:B40:
Sub WriteToFirstAvailableCellInRange()
Dim wb As Workbook
Dim ws As Worksheet
Dim firstEmptyCell As Range
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
If ws.Range("B15").Value = "" Then
Set firstEmptyCell = ws.Range("B15")
Else
If ws.Range("B16").Value = "" Then
Set firstEmptyCell = ws.Range("B16")
Else
Set firstEmptyCell = ws.Range("B15").End(xlDown).Offset(1)
End If
End If
If firstEmptyCell.Row < 41 Then
firstEmptyCell.Value = "3300-0401"
Else
MsgBox "There aren't any empty cells in range B15:B40."
End If
End Sub