I want to paste certain rows into a certain sheet if a string is entered into a textbox.
I have is a userform that I'd like to paste entries into Month specific sheets based on the date textbox.
I can copy to one specific sheet, but I'd like to auto sort into the appropriate Month sheet based on the value entered in DT.value.
Private Sub Submit_Click()
Dim ws As Worksheet
Dim LastRow As Long
If DT.Value = "nov" Then
Set ws = ThisWorkbook.Worksheets("NOV")
Else
If DT.Value = "dec" Then
Set ws = ThisWorkbook.Worksheets("DEC")
Else
If DT.Value = "Jan" Then
Set ws = ThisWorkbook.Worksheets("JAN")
Else
If DT.Value = "Feb" Then
Set ws = ThisWorkbook.Worksheets("FEB")
Else
If DT.Value = "mar" Then
Set ws = ThisWorkbook.Worksheets("MAR")
Else
If DT.Value = "Apr" Then
Set ws = ThisWorkbook.Worksheets("APR")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
'other code that works below.
With this code I end up with Type Mismatch or nothing gets copied.
I'd like the user to enter a date in the dt.value box and the data paste to the appropriate sheet based on that value.
It depends on how you have named your tabs and how your date is imputed in the textbox.
But if you are using mar and MAR, here is a simple code to assign the worksheet variable using the text in the userform textbox.
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(Me.DT.Text)
Update to basic code:
Private Sub CommandButton1_Click()
'Check if the textbox has a valid date
If IsDate(Me.DT.Text) Then
Me.DT.Text = Format(CDate(Me.DT.Text), "mmm") 'Format as abrivated month
'Define and Assign worksheet and newRow variables
Dim ws As Worksheet, newRow As Long
Set ws = ThisWorkbook.Worksheets(Me.DT.Text)
newRow = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
With ws 'When writing other textbox values to the worksheet; change TextBox# as required
.Cells(newRow, 1).Value = Me.TextBox1.Text
.Cells(newRow, 2).Value = Me.TextBox2.Text
.Cells(newRow, 3).Value = Me.TextBox3.Text
.Cells(newRow, 4).Value = Me.TextBox4.Text
End With
Application.Goto ws.Range("A1"), Scroll:=True 'Set the focus to the first cell on the worksheet
Else 'If a valid date is not entered display a message box
MsgBox "Please enter a valid date"
Cancel = True
End If
End Sub
Related
I have a simple Userform with two textboxes. User is to enter Part Description in one labelled "Panel ID" and the number of rows that description is to be entered in the same column of the spreadsheet (Quantity). By now, I am OK with adding value in empty row, but got stuck at copying the value to other cells. I have code for copying the value in set range, but cannot find anything that works for what I am looking for. Thanks
Apples Oranges List
Private Sub SubmitBtn_Click()
Dim iRow As Long, C As Long
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Data")
iRow = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
C = QTYBox.Value
With sh
.Cells(iRow, 1) = TxtPanel.Value
End With
End Sub
Private Sub UserForm_Initialize()
'Empty Panel ID cell
TxtPanel.Value = ""
'Empty Quantity cell
QTYBox.Value = ""
'Set focus to panel ID cell
TxtPanel.SetFocus
End Sub
This is code for second problem:
crate form
crate spreadsheet
Private Sub SubmitBtn_Click()
Dim i As Long
Dim sh As Worksheet
Dim lRow As Long
Set sh = ThisWorkbook.Sheets("Data")
lRow = sh.Cells(Rows.Count, 1).End(xlUp).Row
With sh
For i = 2 To lRow
'Criteria search
If .Cells(i, 1).Value = PanelTxt.Value Then
If .Cells(i, 2).Value = IDTxt.Value Then
'Enter date in Crated and Crate #
.Cells(i, 5) = [Text(Now(), "DD-MM-YY HH:MM")]
.Cells(i, 6) = CrateTxt.Value
Exit For
End If
End If
Next
End With
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 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)
I have a Pivot table whose row number could change depending on the data. I want to copy the pivot table and paste it as values starting from column B in another existing sheet.
To do this, i first tried getting the name of the pivot and stored it in a named range using the following code:
Sub ListPivotsInfor()
Dim St As Worksheet
Dim NewSt As Worksheet
Dim pt As PivotTable
Dim I, K As Long
Application.ScreenUpdating = False
Set NewSt = Worksheets.Add
ActiveSheet.Name = "ListOfPivotTables"
I = 1: K = 2
With NewSt
.Cells(I, 1) = "Name"
.Cells(I, 2) = "Sheet"
.Cells(I, 3) = "Location"
For Each St In ActiveWorkbook.Worksheets
For Each pt In St.PivotTables
I = I + 1
.Cells(I, 1).Value = pt.Name
.Cells(I, 2).Value = St.Name
.Cells(I, 3).Value = pt.TableRange1.Address
Next
Next
.Activate
End With
Application.ScreenUpdating = True
Dim cell As Range
Dim rng As Range
Dim RangeName As String
Dim CellName As String
'Single Cell Reference (Workbook Scope)
RangeName = "PivotName"
CellName = "A2"
Set cell = Worksheets("ListOfPivotTables").Range(CellName)
ThisWorkbook.Names.Add Name:=RangeName, RefersTo:=cell
I later tried to copy the pivot table and paste it in another sheet using the following code:
Worksheets.Add
ActiveSheet.Name = "GEP"
Worksheets("GEP Write").PivotTables(PivotName).TableRange2.Copy Destination:=Worksheets("GEP").Range("B1")
The last line is throwing a "Run time error 1004: Unable to get the PivtoTables property of the worksheet class".
Appreciate any help.
Regards
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