I am wondering if anyone could help me with this. I have written vba code to achieve goal when i click on "Button1" macro button in my sheet1 to open userform2 with a searchbox(TextBox) one CommandButton and List in it.
I have divided the Problem into two Parts. One is working for me and the second one is not.
Problem 1 working:
Than in searchBox I will write some Name(characters) to do a search from existing sheet1 by clicking on SearchButton1. If it finds the data against that search(Name) than
Problem 2 not working:
I should be able to edit and save all the data stored against that Name in new userform I have created by the name of Userform33 having 15 TextBoxes and 2 commandButtons in it, one button for "Edit and save" and second for "close form".
Here is my code for userform2 that will show the data in the form of
List based on input in SearchBox
Code Problem 1 WORKING FINE:
> Option Explicit
>
> Private Sub TextBox1_Change() Me.TextBox1 =
> Format(StrConv(Me.TextBox1, vbLowerCase)) 'hier schreibt er nur noch
> klein
>
> Dim sh As Worksheet Set sh = Worksheets("LEADS DE") Dim i As Long Dim
> x As Long Dim p As Long Me.ListBox1.Clear
>
> 'For ListBox Header Me.ListBox1.AddItem "#"
> Me.ListBox1.List(ListBox1.ListCount - 1, 2) = leads.Cells(1, 6).Value
> Me.ListBox1.List(ListBox1.ListCount - 1, 3) = leads.Cells(1, 7).Value
> Me.ListBox1.List(ListBox1.ListCount - 1, 4) = leads.Cells(1, 19).Value
> Me.ListBox1.List(ListBox1.ListCount - 1, 5) = leads.Cells(1, 4).Value
> Me.ListBox1.List(ListBox1.ListCount - 1, 6) = leads.Cells(1, 21).Value
> Me.ListBox1.List(ListBox1.ListCount - 1, 7) = leads.Cells(1, 18).Value
>
>
>
> For i = 2 To sh.Range("B" & Rows.Count).End(xlUp).Row For x = 1 To
> Len(sh.Cells(i, 2)) p = Me.TextBox1.TextLength
>
> If LCase(Mid(sh.Cells(i, 6), x, p)) = Me.TextBox1 And Me.TextBox1 <>
> "" Then 'Mid(sh.Cells(i, 3 <-- die 3 zeigt wo gesucht werden soll
> With Me.ListBox1 .AddItem sh.Cells(i, 2) '.List(ListBox1.ListCount -
> 1, 1) = sh.Cells(i, 3) .List(ListBox1.ListCount - 1, 2) = sh.Cells(i,
> 6) .List(ListBox1.ListCount - 1, 3) = sh.Cells(i, 7)
> .List(ListBox1.ListCount - 1, 4) = sh.Cells(i, 19)
> .List(ListBox1.ListCount - 1, 5) = sh.Cells(i, 4)
> .List(ListBox1.ListCount - 1, 6) = sh.Cells(i, 21)
> .List(ListBox1.ListCount - 1, 7) = sh.Cells(i, 18)
>
> End With
>
>
> End If Next x Next i
>
>
> End Sub
>
>
> Private Sub UserForm_Initialize() Dim Zeile As Long
>
> Me.ListBox1.AddItem "#"
>
>
> Me.ListBox1.List(ListBox1.ListCount - 1, 1) = leads.Cells(1, 6).Value
> Me.ListBox1.List(ListBox1.ListCount - 1, 2) = leads.Cells(1, 7).Value
> Me.ListBox1.List(ListBox1.ListCount - 1, 3) = leads.Cells(1, 19).Value
> Me.ListBox1.List(ListBox1.ListCount - 1, 4) = leads.Cells(1, 4).Value
> Me.ListBox1.List(ListBox1.ListCount - 1, 5) = leads.Cells(1, 21).Value
> Me.ListBox1.List(ListBox1.ListCount - 1, 6) = leads.Cells(1, 18).Value
>
> For Zeile = 2 To leads.Cells(Rows.Count, 2).End(xlUp).Row
> Me.ListBox1.AddItem leads.Cells(Zeile, 2).Value
> Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = leads.Cells(Zeile, 6).Value
> Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2) = leads.Cells(Zeile, 7).Value
> Me.ListBox1.List(Me.ListBox1.ListCount - 1, 3) = leads.Cells(Zeile, 19).Value
> Me.ListBox1.List(Me.ListBox1.ListCount - 1, 4) = leads.Cells(Zeile, 4).Value
> Me.ListBox1.List(Me.ListBox1.ListCount - 1, 5) = leads.Cells(Zeile, 21).Value
> Me.ListBox1.List(Me.ListBox1.ListCount - 1, 6) = leads.Cells(Zeile, 18).Value
> Me.ListBox1.List(Me.ListBox1.ListCount - 1, 7) = leads.Cells(Zeile, 18).Row
> Next Zeile
> End Sub
Well above code is working fine!!!
Now Code for Problem 2 which is Not Working for Me!
Private Sub CommandButton1_Click()
Dim check_data As Characters
check_data = Sheets("LEADS DE").Range("F")
If check_data = UserForm2.TextBox1 Then
UserForm33.TextBox1 = Sheets("LEADS DE").Range("B")
UserForm33.TextBox5 = Sheets("LEADS DE").Range("F")
UserForm33.TextBox8 = Sheets("LEADS DE").Range("I")
UserForm33.TextBox9 = Sheets("LEADS DE").Range("J")
UserForm33.TextBox6 = Sheets("LEADS DE").Range("G")
UserForm33.TextBox7 = Sheets("LEADS DE").Range("H")
UserForm33.TextBox10 = Sheets("LEADS DE").Range("K")
UserForm33.TextBox11 = Sheets("LEADS DE").Range("L")
UserForm33.TextBox14 = Sheets("LEADS DE").Range("D")
UserForm33.TextBox12 = Sheets("LEADS DE").Range("N")
UserForm33.TextBox15 = Sheets("LEADS DE").Range("O")
UserForm33.TextBox4 = Sheets("LEADS DE").Range("M")
UserForm33.TextBox16 = Sheets("LEADS DE").Range("P")
UserForm33.TextBox17 = Sheets("LEADS DE").Range("Q")
UserForm33.TextBox18 = Sheets("LEADS DE").Range("R")
UserForm33.Show
End If
End Sub
Main Problem:
I am stuck in Problem 2 and not able to show the data that comes from search in the form of List into newly created UserForm33 and than " edit(update) and save data " on the same userform33.
Any help is very appreciated from Experts.
Thanks,
Add another column to the Listbox and use column 0 to store the row number for the record. You can set column width to 0 to hide. Add a label to the UserForm33 to store the row number on the spreadsheet that is being edited.
UserForm2 code
Option Explicit
Private Sub CommandButton1_Click() ' Edit
Dim i As Long, r As Long
With ListBox1
i = .ListIndex ' selected row
If i < 1 Then Exit Sub
r = .List(i, 0) ' source row from sheet
End With
Call UserForm33.LoadForm(r)
End Sub
Private Sub TextBox1_Change()
Me.TextBox1 = Format(StrConv(Me.TextBox1, vbLowerCase)) 'hier schreibt er nur noch klein
Me.ListBox1.Clear
Call FillListbox(Me.TextBox1.Text)
End Sub
Private Sub UserForm_Initialize()
Call FillListbox("")
'ListBox1.ColumnWidths = "0" hide
End Sub
Private Sub FillListbox(s As String)
Dim Zeile As Long, Lastrow As Long, i As Long, c As Long
Dim ws As Worksheet, ar
ar = Array("B", "F", "G", "S", "D", "U", "R")
Set ws = Sheets("LEADS DE")
Lastrow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
With Me.ListBox1
For Zeile = 1 To Lastrow
If Zeile = 1 Or s = "" _
Or LCase(ws.Cells(Zeile, "F")) Like "*" & s & "*" Then
.AddItem "#"
i = .ListCount - 1
.List(i, 0) = Zeile
For c = 0 To UBound(ar)
.List(i, c + 1) = ws.Cells(Zeile, ar(c))
Next
End If
Next
.List(0, 1) = "#"
End With
End Sub
UserForm33 code
Option Explicit
Private Sub CommandButton1_Click() ' Save
Call SaveForm
End Sub
Sub LoadForm(r As Long)
Dim ws As Worksheet, arBox, arCol, i As Long
arBox = Split("1,5,8,9,6,7,10,11,14,12,15,4,16,17,18", ",")
arCol = Split("B,F,I,J,G,H,K,L,D,N,O,M,P,Q,R", ",")
Set ws = Sheets("LEADS DE")
With Me
.Label1 = r
For i = 0 To UBound(arBox)
.Controls("TextBox" & arBox(i)) = ws.Cells(r, arCol(i))
Next
.Show
End With
End Sub
Sub SaveForm()
Dim ws As Worksheet, arBox, arCol, i As Long, r As Long
arBox = Split("1,5,8,9,6,7,10,11,14,12,15,4,16,17,18", ",")
arCol = Split("B,F,I,J,G,H,K,L,D,N,O,M,P,Q,R", ",")
Set ws = Sheets("LEADS DE")
With Me
r = .Label1
For i = 0 To UBound(arBox)
ws.Cells(r, arCol(i)) = .Controls("TextBox" & arBox(i))
Next
End With
End Sub
Related
I'm working on a sub where, after doing a whole bunch of other things, it just selects all the cells in the active sheet and sets the rows to auto-fit height. For some reason it won't work! I've tried to the autofit row height command in various different places, but it seems that so long as it's part of the larger sub, or called within it, it won't work. However, if I write a separate sub that is run separately, it will work just fine. Does anyone know why this could be?
Below is the sub where it's misbehaving, plus the other sub I made that I can run separately. Any suggestions on how to make this all more efficient is also very welcome! (I also kind of learned coding in the wild, so I don't really know best practices...)
Option Explicit
Sub WriteToIndex(ByRef rowsArray() As Variant, ByRef Indexes() As Integer, ByRef HeaderNames() As String, myTable As ListObject, sheetName As String)
Debug.Print sheetName
Sheets(sheetName).Activate
Dim i, j As Variant
Dim count As Integer
'If no rows, no write
If (Not Not rowsArray) <> 0 Then
Else:
'If the index is longer than 5000 rows, this will need to be updated!
Range("B4:L5000").Clear
MsgBox "Sheet " & sheetName & " was not populated because there is nothing attributed to it"
Exit Sub
End If
'If nothing in Int/Ext section, no write
count = 0
For i = LBound(rowsArray) To UBound(rowsArray)
For j = LBound(Indexes) To UBound(Indexes)
If myTable.DataBodyRange(rowsArray(i), Indexes(j)).Value = "n" Then count = count + 1
Next
Next
If count = 0 Then
'If the index is longer than 5000 rows, this will need to be updated!
Range("B4:L5000").Clear
MsgBox "Sheet " & sheetName & " was not populated because there is nothing attributed to it"
Exit Sub
End If
Sheets(sheetName).Activate
'Pulls desired index fonts and sizes from Settings tab
Dim IndexFont As String, HeaderFSize, BodyFSize As Integer, HeaderBold As Boolean
IndexFont = Worksheets("Settings").Cells(10, 11).Value
HeaderFSize = Worksheets("Settings").Cells(11, 11).Value
HeaderBold = Worksheets("Settings").Cells(12, 11).Value
BodyFSize = Worksheets("Settings").Cells(13, 11).Value
'Remove headers from array if there are no items for the index
Dim loopno, pos, zeroloops(), zeroloopstart As Integer
count = 0
zeroloopstart = 0
loopno = 1
ReDim Preserve zeroloops(zeroloopstart)
For i = LBound(Indexes) To UBound(Indexes)
For j = LBound(rowsArray) To UBound(rowsArray)
If myTable.DataBodyRange(rowsArray(j), Indexes(i)).Text = "n" Then count = count + 1
Next
If count = 0 Then
pos = loopno - 1
ReDim Preserve zeroloops(0 To zeroloopstart)
zeroloops(zeroloopstart) = pos
zeroloopstart = zeroloopstart + 1
End If
count = 0
loopno = loopno + 1
Next
'If a header is in the zeroloops array, it gets removed from the Header array
If IsEmpty(zeroloops(0)) Then
Debug.Print "Empty"
Else
For i = LBound(zeroloops) To UBound(zeroloops)
For j = zeroloops(i) To UBound(Indexes) - 1
Indexes(j) = Indexes(j + 1)
Next j
For j = zeroloops(i) To UBound(HeaderNames) - 1
HeaderNames(j) = HeaderNames(j + 1)
Next j
For j = LBound(zeroloops) To UBound(zeroloops)
zeroloops(j) = zeroloops(j) - 1
Next j
Debug.Print
ReDim Preserve Indexes(0 To (UBound(Indexes) - 1))
ReDim Preserve HeaderNames(0 To (UBound(HeaderNames) - 1))
Next i
End If
'If the index is longer than 5000 rows, this will need to be updated!
Range("B4:L5000").Clear
'Apply preferred font to entire sheet
Cells.Font.Name = IndexFont
Dim KeyIDCol, DescCol, SourceCol, ProductCol, CatCol, ColorCol, FinishCol, SizeCol, ContactCol, SpecCol, RemarkCol As Integer
'Index for each value to report
'If additional column needs to be reported, add the line and swap out the name in the Listcolumns definition
KeyIDCol = Worksheets("Database").ListObjects("Database").ListColumns("KEYNOTE #").Index
DescCol = Worksheets("Database").ListObjects("Database").ListColumns("KEYNOTE DESCRIPTION").Index
SourceCol = Worksheets("Database").ListObjects("Database").ListColumns("SOURCE").Index
ProductCol = Worksheets("Database").ListObjects("Database").ListColumns("PRODUCT").Index
CatCol = Worksheets("Database").ListObjects("Database").ListColumns("CAT. NO.").Index
ColorCol = Worksheets("Database").ListObjects("Database").ListColumns("COLOR").Index
FinishCol = Worksheets("Database").ListObjects("Database").ListColumns("FINISH").Index
SizeCol = Worksheets("Database").ListObjects("Database").ListColumns("SIZE").Index
ContactCol = Worksheets("Database").ListObjects("Database").ListColumns("CONTACT").Index
SpecCol = Worksheets("Database").ListObjects("Database").ListColumns("SECTION #").Index
RemarkCol = Worksheets("Database").ListObjects("Database").ListColumns("REMARKS").Index
'Definitions for write loop
Dim NextWriteRow, HeaderListIndex As Integer
Dim ArrayItem As Variant
Dim WriteStartCell, Cell As Range
NextWriteRow = 4
HeaderListIndex = 0
i = 1 ' for moving to the next KeyID
j = 0 ' start counter for steps
Set WriteStartCell = Cells(NextWriteRow, 2)
Dim k As Variant
'Outer loop puts in headers
For Each ArrayItem In Indexes
With Cells(NextWriteRow, 2)
.Value = HeaderNames(HeaderListIndex)
.VerticalAlignment = xlBottom
.Font.Size = HeaderFSize
.Font.Bold = HeaderBold
End With
HeaderListIndex = HeaderListIndex + 1
'Second loop puts in KeynoteID with all pertinent info
For k = LBound(rowsArray) To UBound(rowsArray)
If myTable.DataBodyRange(rowsArray(k), ArrayItem).Value = "n" Then
With WriteStartCell
.Offset(i, 0).Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, KeyIDCol - ArrayItem).Value
.Offset(i, 1).Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, DescCol - ArrayItem).Value
.Offset(i, 2).Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, SourceCol - ArrayItem).Value
.Offset(i, 3).Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, ProductCol - ArrayItem).Value
.Offset(i, 4).Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, CatCol - ArrayItem).Value
.Offset(i, 5).Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, ColorCol - ArrayItem).Value
.Offset(i, 6).Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, FinishCol - ArrayItem).Value
.Offset(i, 7).Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, SizeCol - ArrayItem).Value
.Offset(i, 8).Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, ContactCol - ArrayItem).Value
With .Offset(i, 9)
.NumberFormat = "000000"
.HorizontalAlignment = xlCenter
.Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, SpecCol - ArrayItem).Value
End With
.Offset(i, 10).Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, RemarkCol - ArrayItem).Value
End With
With Range(WriteStartCell.Offset(i, 0), WriteStartCell.Offset(i, 10))
.VerticalAlignment = xlTop
.WrapText = True
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Font.Size = BodyFSize
With .Borders
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
End With
i = i + 1
j = j + 1
End If
Next
j = j + 2
NextWriteRow = NextWriteRow + j
i = i + 2
j = 0
Next
'This is the autofit that won't work for some reason
Cells.Rows.Autofit
Debug.Print "Works"
End Sub
'---
Sub AutofitRowHeight()
Dim sheetnames() As String
ReDim sheetnames(0 To 17)
sheetnames(0) = "SF-ALL-I"
sheetnames(1) = "SF-ALL-E"
sheetnames(2) = "SF-H-I"
sheetnames(3) = "SF-H-E"
sheetnames(4) = "SF-CUP-I"
sheetnames(5) = "SF-CUP-E"
sheetnames(6) = "SF-GB-I"
sheetnames(7) = "SF-GB-E"
sheetnames(8) = "LM-ALL-I"
sheetnames(9) = "LM-ALL-E"
sheetnames(10) = "LM-H-I"
sheetnames(11) = "LM-H-E"
sheetnames(12) = "LM-CC-I"
sheetnames(13) = "LM-CC-E"
sheetnames(14) = "LM-SCC-I"
sheetnames(15) = "LM-SCC-E"
sheetnames(16) = "LM-GB-I"
sheetnames(17) = "LM-GB-E"
Dim i As Variant
For i = LBound(sheetnames) To UBound(sheetnames)
Sheets(sheetnames(i)).Activate
Cells.Rows.AutoFit
Next
Sheets("Database").Activate
Cells(1, 1).Select
End Sub
I have a problem with displaying multiple columns in a ListBox in my UserForm.
Everything is working until my numbers of column is max 10.
My code:
Private Sub FindButton_Click()
ListBoxResult.Clear
ListBoxResult.ColumnCount = 14
Dim RowNum As Long
RowNum = 1
Do Until Sheets("db").Cells(RowNum, 1).Value = ""
If InStr(1, Sheets("db").Cells(RowNum, 2).Value, FindDMC.Value, vbTextCompare) > 0 Then
On Error GoTo next1
ListBoxResult.AddItem Sheets("db").Cells(RowNum, 1).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 2) = Sheets("db").Cells(RowNum, 2).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 3) = Sheets("db").Cells(RowNum, 3).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 4) = Sheets("db").Cells(RowNum, 4).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 5) = Sheets("db").Cells(RowNum, 5).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 6) = Sheets("db").Cells(RowNum, 6).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 7) = Sheets("db").Cells(RowNum, 7).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 8) = Sheets("db").Cells(RowNum, 8).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 9) = Sheets("db").Cells(RowNum, 9).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 10) = Sheets("db").Cells(RowNum, 10).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 11) = Sheets("db").Cells(RowNum, 11).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 12) = Sheets("db").Cells(RowNum, 12).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 13) = Sheets("db").Cells(RowNum, 13).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 14) = Sheets("db").Cells(RowNum, 14).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 15) = Sheets("db").Cells(RowNum, 15).Value
End If
next1:
RowNum = RowNum + 1
Loop
End Sub
ListBoxResult.ColumnCount and properties is 14, also Column widths is ok.
After runing my code the failure code is Run-time error '380': Could not set the List property. Invalid property value. At first, I was thinking that maybe ListBoxes have limits for columns, but I found ListBoxes with 60 columns on the Internet.
I am trying also this, but still doesn't work:
Private Sub Browser_RMA_Initialize()
ListBoxResult.RowSource = "db!a1:z1"
ListBoxResult.ColumnCount = 14
ListBoxResult.ColumnWidths = "50;50;50;50;50;50;50;50;50;50;50;50;50;50;"
ListBoxResult.ColumnHeads = True
End Sub
Could you support me, please?
Assigning to .Columnproperty avoids transposing
As late addition to #Dy.Lee 's valid and already accepted array approach (see my comment), I demonstrate a way how to avoid both repeated redimming [4] and transposing [5]:
Option Explicit ' declaration head of UserForm code module
Private Sub FindButton_Click()
'[0] where to search
Const SearchCol As Long = 2 ' get search items from 2nd column
'[1] define data set
Dim data As Variant
data = Tabelle1.Range("A1").CurrentRegion ' << change to your project's sheet Code(Name)
Dim ii As Long: ii = UBound(data, 1) ' row count
Dim jj As Long: jj = UBound(data, 2) ' column count
'[2] provide for sufficient result rows (array with converted row : columns order)
Dim results() As Variant
ReDim Preserve results(1 To jj, 1 To ii) ' redim up to maximum row count ii
'[3] assign filtered data
Dim i As Long, j As Integer, n As Long
For i = 1 To ii
If InStr(1, data(i, SearchCol), FindDMC.Value, vbTextCompare) > 0 Then
'' If data(i, SearchCol) = FindDMC.Value Then ' exact findings
n = n + 1
For j = 1 To jj
results(j, n) = data(i, j)
Next
End If
Next i
'[4] fill listbox with results
With ListBoxResult
.Clear
.ColumnCount = 14
.ColumnWidths = "50;50;50;50;50;50;50;50;50;50;50;50;50;50;"
If n Then
'[4] redimension only a 2nd time (& last time)
ReDim Preserve results(1 To jj, 1 To n)
'[5] assign results to listbox'es .Column property
.Column = results ' << .Column property avoids unnecessary transposing
End If
End With
End Sub
The column index of the listbox also starts at 0. The index number of additem should be 0, and you specified 15 at the end, then the number of columns becomes 16, so an error occurs because column 14 is exceeded.
It would be convenient to use an array.
Private Sub FindButton_Click()
Dim Ws As Worksheet
Dim vDB As Variant, vResult()
Dim i As Long, j As Integer, n As Long
Set Ws = Sheets("db")
vDB = Ws.Range("a1").CurrentRegion
For i = 1 To UBound(vDB, 1)
If InStr(1, vDB(i, 2), FindDMC.Value, vbTextCompare) > 0 Then
n = n + 1
ReDim Preserve vResult(1 To 14, 1 To n)
For j = 1 To 14
vResult(j, n) = vDB(i, j)
Next
End If
Next i
With ListBoxResult
.Clear
.ColumnCount = 14
.ColumnWidths = "50;50;50;50;50;50;50;50;50;50;50;50;50;50;"
If n Then
If n = 1 Then
.Column = vResult
Else
.List = WorksheetFunction.Transpose(vResult)
End If
End If
End With
End Sub
I'm trying to create a UserForm which will open when I select a command button. The purpose of it is to capture data from a selected row concerning a "tour" - i.e. the tour code, start date and end date, and then for me to "split" the tour, for which I need to enter new tour codes, start dates and end dates.
I need the data from the form to go into a separate sheet (called "splits"), so that I have a record of the original tour details, and the new tour details in one sheet. But I get a Run-Time error '1004' (Application-defined or object-defined error) when I try to run the macro. I'm new to VBA and I don't know what I've done wrong!
This is my code so far:
Private Sub UserForm_Initialize()
With Me
.OriginalTourCode.Value = Cells(ActiveCell.Row, "A").Value
.OriginalStartDate.Value = Cells(ActiveCell.Row, "B").Value
.OriginalEndDate.Value = Cells(ActiveCell.Row, "C").Value
End With
End Sub
Private Sub SplitTourCommand_Click()
Dim ctrl As Control
Dim ws As Worksheet
Set ws = Sheets("Splits")
erow = ws.Cells(Rows.Count, 1).End(x1Up).Offset(1, 0)
Cells(erow, 1) = OriginalTourCode.Text
Cells(erow, 2) = OriginalStartDate.Text
Cells(erow, 3) = OriginalEndDate.Text
Cells(erow, 4) = NewTourCode1.Text
Cells(erow, 5) = NewStartDate1.Text
Cells(erow, 6) = NewEndDate1.Text
Cells(erow, 7) = NewTourCode2.Text
Cells(erow, 8) = NewStartDate2.Text
Cells(erow, 9) = NewEndDate2.Text
Cells(erow, 10) = ReasonForSplit.Text
End Sub
Private Sub CloseCommand_Click()
Unload Me
End Sub
The Userform Intitialise section automatically fills in the first three cells of the UserForm, and then I'll use the form to enter the new data.
The Close command section is just a separate button on the form to exit out.
How to I get the form, when I click the "split tour" command button, to enter the data into the next empty row of the "splits" sheet?
Thanks so much in advance for helping.
erow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
There were 2 errors in your code. First, the command is xlUp, not x1Up - "xl" is short for "Excel", not "X One" - this is a perfect example of why you should almost always use Option Explicit
Second: your code as-is will try to put the .Value from the cell into untyped variable erow - since the cell is blank (as the cell below the last cell with data), this means that erow will always be 0. And Row 0 does not exist to put data into.
Instead, by using Range.Row, we get the next row number to insert data on
You were so close
Dim ctrl As Control
Dim ws As Worksheet
Set ws = Sheets("Splits")
erow = ws.Cells(Rows.Count, 1).End(x1Up).Offset(1, 0)
ws.Cells(erow, 1) = OriginalTourCode.Text
ws.Cells(erow, 2) = OriginalStartDate.Text
ws.Cells(erow, 3) = OriginalEndDate.Text
ws.Cells(erow, 4) = NewTourCode1.Text
ws.Cells(erow, 5) = NewStartDate1.Text
ws.Cells(erow, 6) = NewEndDate1.Text
ws.Cells(erow, 7) = NewTourCode2.Text
ws.Cells(erow, 8) = NewStartDate2.Text
ws.Cells(erow, 9) = NewEndDate2.Text
ws.Cells(erow, 10) = ReasonForSplit.Text
End Sub
No Object Variable Necessary
The End Parameter is xlUp not x1Up.
Array Version
Option Explicit
Private Sub SplitTourCommand_Click()
Const cSheet As String = "Splits"
Dim erow As Long
Dim vnt As Variant
ReDim vnt(1 To 1, 1 To 10) As String
vnt(1, 1) = OriginalTourCode.Text
vnt(1, 2) = OriginalStartDate.Text
vnt(1, 3) = OriginalEndDate.Text
vnt(1, 4) = NewTourCode1.Text
vnt(1, 5) = NewStartDate1.Text
vnt(1, 6) = NewEndDate1.Text
vnt(1, 7) = NewTourCode2.Text
vnt(1, 8) = NewStartDate2.Text
vnt(1, 9) = NewEndDate2.Text
vnt(1, 10) = ReasonForSplit.Text
With Worksheets(cSheet)
erow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(erow, 1).Resize(, 10) = vnt
End With
End Sub
Range Version
Option Explicit
Private Sub SplitTourCommand_Click()
Const cSheet As String = "Splits"
Dim erow As Long
With Worksheets(cSheet)
erow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(erow, 1) = OriginalTourCode.Text
.Cells(erow, 2) = OriginalStartDate.Text
.Cells(erow, 3) = OriginalEndDate.Text
.Cells(erow, 4) = NewTourCode1.Text
.Cells(erow, 5) = NewStartDate1.Text
.Cells(erow, 6) = NewEndDate1.Text
.Cells(erow, 7) = NewTourCode2.Text
.Cells(erow, 8) = NewStartDate2.Text
.Cells(erow, 9) = NewEndDate2.Text
.Cells(erow, 10) = ReasonForSplit.Text
End With
End Sub
This is the updated code. I am getting a mismatch error now. It would be great if someone could offer some help. Thanks in advance!
Sub Macro2()
Dim rowcount As Long
Dim target As Variant, startcell4 As Range
Set startcell4 = ActiveSheet.Cells(2, 1)
rowcount = Range(Range("E2"), Range("E2").End(xlDown)).Rows.Count
For i = 2 To rowcount + 1
If Not ActiveSheet.Cells(i, 26) = ActiveSheet.Cells(i + 1, 26) Then
Set target = Application.Match(ActiveSheet.Cells(i, 26), Worksheets(19).Range("A6:A3000"), 0)
If Not IsError(target) Then
ActiveSheet.startcell4.Offset(0, 17).Value = Worksheets(19).Cells(target + 6, 10)
Set startcell4 = ActiveSheet.Cells(i + 1, 26)
End If
End If
Next i
End Sub
Changed:
"Set target = ..." to "target = ..."
"ActiveSheet.startcell4" to "startcell4"
A little refactoring
Coming to this
Sub Macro2()
Dim rowcount As Long
Dim target As Variant, startcell4 As Range
Set startcell4 = Cells(2, 1)
rowcount = Range("E2").End(xlDown).Row
For i = 2 To rowcount
If Not Cells(i, 26) = Cells(i + 1, 26) Then
target = Application.Match(Cells(i, 26), Worksheets(19).Range("A6:A3000"), 0)
If Not IsError(target) Then
startcell4.Offset(0, 17).Value = Worksheets(19).Cells(target + 6, 10)
Set startcell4 = Cells(i + 1, 26)
End If
End If
Next i
End Sub
I'm trying to share a sheet with a button that open a new window(made in vb) but when I share it the button that guides to another window lock simple doesn't work (yes I unchecked lock), theres something I need to do to share that button and the another window?
The work of this windows is to edit cells.
Here's the code from the window, there's:
private Sub CommandButton1_Click()
Dim i, a, b, c, d
Dim prio As String
i = CInt(Sheets("Sheet1").Cells(6, 17))
a = CInt(Sheets("Sheet1").Cells(7, 17))
Sheets("Sheet1").Cells(i, 1) = a
Sheets("Sheet1").Cells(i, 2) = Peca.Text
Sheets("Sheet1").Cells(i, 3) = Qt.Text
Sheets("Sheet1").Cells(i, 4) = ComboBox1.Value
Sheets("Sheet1").Cells(i, 5) = Responsavel.Text
Sheets("Sheet1").Cells(i, 6) = Cliente.Text
Sheets("Sheet1").Cells(i, 7) = Maquina.Text
Sheets("Sheet1").Cells(i, 8) = NumSerie.Text
Sheets("Sheet1").Cells(i, 9) = Modelo.Text
Sheets("Sheet1").Cells(i, 10) = Obser.Text
Sheets("Sheet1").Cells(6, 17) = CInt(Sheets("Sheet1").Cells(6, 17)) + 1
Sheets("Sheet1").Cells(7, 17) = CInt(Sheets("Sheet1").Cells(7, 17)) + 1
Peca.Text = ""
Qt.Text = ""
ComboBox1.Value = ""
Responsavel.Text = ""
Cliente.Text = ""
Maquina.Text = ""
NumSerie.Text = ""
Modelo.Text = ""
Obser.Text = ""
End Sub
Private Sub CommandButton2_Click()
Sheets("Sheet1").Cells(12, 15) = Cliente.Text
End Sub
Private Sub CommandButton3_Click()
Sheets("Sheet1").Cells(12, 15) = Maquina.Text
Sheets("Sheet1").Cells(13, 15) = NumSerie.Text
Sheets("Sheet1").Cells(14, 15) = Modelo.Text
End Sub
Private Sub CommandButton4_Click()
Cliente.Text = Sheets("Sheet1").Cells(12, 15)
End Sub
Private Sub CommandButton5_Click()
Maquina.Text = Sheets("Sheet1").Cells(12, 15)
NumSerie.Text = Sheets("Sheet1").Cells(13, 15)
Modelo.Text = Sheets("Sheet1").Cells(14, 15)
End Sub