VBA Userform textbox remembering the last entry - vba

I am new to VBA and I have a question. I have created a userform in excel. So, my question is that I want to enter values in the textbox and submit, the next time I launch the userform, it remembers the last entry in the userform. So, for example, I have textbox called facility. I enter in value UHN for the first time. Once I have closed the userform. Then I open the userform again, the value UHN is already filled in so the user does not need to type it again. So, the user form remembers the last entry in the textbox.
Thank you in advance!
My vba code is as follows:
Option Explicit
Private Sub AddlistButton_Click()
Dim emptyRow As Long
wsmenu.Activate
emptyRow = WorksheetFunction.CountA(Range("A:A"))
Me.Hide
wsfilms.Select
'Range("a1").End(xlDown).Offset(1, 0).Select
Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Select
'Add facility name
ActiveCell.Value = FacilityBox
'Add service area
ActiveCell.Offset(0, 1).Value = ServiceAreaBox
'Add date
ActiveCell.Offset(0, 2).Value = DateBox
'Add time
ActiveCell.Offset(0, 3).Value = TimeBox.Value
'Add room
ActiveCell.Offset(0, 4).Value = RoomBox.Value
'Briefing Question 1
If Yes1.Value = True Then
ActiveCell.Offset(0, 5).Value = "Yes"
Else
ActiveCell.Offset(0, 5).Value = "No"
End If
'Timeout Question 1
If Yes2.Value = True Then
ActiveCell.Offset(0, 6).Value = "Yes"
Else
ActiveCell.Offset(0, 6).Value = "No"
End If
If Yes3.Value = True Then
'Debriefing Question 1
ActiveCell.Offset(0, 7).Value = "Yes"
Else
ActiveCell.Offset(0, 7).Value = "No"
End If
'Comment 1
ActiveCell.Offset(0, 8).Value = Comment1.Value
'Briefing Question 2
If Yes4.Value = True Then
ActiveCell.Offset(0, 9).Value = "Yes"
Else
ActiveCell.Offset(0, 9).Value = "No"
End If
'Timeout Question 2
If Yes5.Value = True Then
ActiveCell.Offset(0, 10).Value = "Yes"
Else
ActiveCell.Offset(0, 10).Value = "No"
End If
'Debriefing Question 2
If Yes6.Value = True Then
ActiveCell.Offset(0, 11).Value = "Yes"
Else
ActiveCell.Offset(0, 11).Value = "No"
End If
'Comment 2
ActiveCell.Offset(0, 12).Value = Comment2.Value
'Briefing Question 3
If Yes7.Value = True Then
ActiveCell.Offset(0, 13).Value = "Yes"
Else
ActiveCell.Offset(0, 13).Value = "No"
End If
'Timeout Question 3
If Yes8.Value = True Then
ActiveCell.Offset(0, 14).Value = "Yes"
Else
ActiveCell.Offset(0, 14).Value = "No"
End If
'Debriefing Question 3
If Yes9.Value = True Then
ActiveCell.Offset(0, 15).Value = "Yes"
Else
ActiveCell.Offset(0, 15).Value = "No"
End If
'Comment 3
ActiveCell.Offset(0, 16).Value = Comment3.Value
'Briefing Question 4
If Yes10.Value = True Then
ActiveCell.Offset(0, 17).Value = "Yes"
Else
ActiveCell.Offset(0, 17).Value = "No"
End If
'Timeout Question 4
If Yes11.Value = True Then
ActiveCell.Offset(0, 18).Value = "Yes"
Else
ActiveCell.Offset(0, 18).Value = "No"
End If
'Debriefing Question 4
If Yes12.Value = True Then
ActiveCell.Offset(0, 19).Value = "Yes"
Else
ActiveCell.Offset(0, 19).Value = "No"
End If
'Comment 4
ActiveCell.Offset(0, 20).Value = Comment4.Value
'Briefing Question 5
If Yes13.Value = True Then
ActiveCell.Offset(0, 21).Value = "Yes"
Else
ActiveCell.Offset(0, 21).Value = "No"
End If
'Timeout Question 5
If Yes14.Value = True Then
ActiveCell.Offset(0, 22).Value = "Yes"
Else
ActiveCell.Offset(0, 22).Value = "No"
End If
'Debriefing Question 5
If Yes15.Value = True Then
ActiveCell.Offset(0, 23).Value = "Yes"
Else
ActiveCell.Offset(0, 23).Value = "No"
End If
'Comment 5
ActiveCell.Offset(0, 24).Value = Comment5.Value
'Briefing Question 6
If Yes16.Value = True Then
ActiveCell.Offset(0, 25).Value = "Yes"
Else
ActiveCell.Offset(0, 25).Value = "No"
End If
'Timeout Question 6
If Yes17.Value = True Then
ActiveCell.Offset(0, 26).Value = "Yes"
Else
ActiveCell.Offset(0, 26).Value = "No"
End If
'Debriefing Question 6
If Yes18.Value = True Then
ActiveCell.Offset(0, 27).Value = "Yes"
Else
ActiveCell.Offset(0, 27).Value = "No"
End If
'Comment 6
ActiveCell.Offset(0, 28).Value = Comment6.Value
'Briefing Question 7
If Yes19.Value = True Then
ActiveCell.Offset(0, 29).Value = "Yes"
Else
ActiveCell.Offset(0, 29).Value = "No"
End If
'Timeout Question 7
If Yes20.Value = True Then
ActiveCell.Offset(0, 30).Value = "Yes"
Else
ActiveCell.Offset(0, 30).Value = "No"
End If
'Debriefing Question 7
If Yes21.Value = True Then
ActiveCell.Offset(0, 31).Value = "Yes"
Else
ActiveCell.Offset(0, 31).Value = "No"
End If
'Comment 7
ActiveCell.Offset(0, 32).Value = Comment7.Value
'Additional Question 8
If Yes22.Value = True Then
ActiveCell.Offset(0, 33).Value = "Yes"
Else
ActiveCell.Offset(0, 33).Value = "No"
End If
'Comment 8
ActiveCell.Offset(0, 34).Value = comment8.Value
'Completed by
ActiveCell.Offset(0, 35).Value = comment9.Value
MsgBox " Data was successfully added to row " & ActiveCell.Row
Unload Me
End Sub
Private Sub CancelButton_Click()
Me.Hide
'Unload FilmDetails
Unload Me
End Sub
Private Sub OptionButton1_Click()
End Sub
Private Sub UserForm_Initialize()
TimeBox.Text = Format(Time, "hh:mm AM/PM")
DateBox.Text = Format(Date, "dd mmm yyyy")
With ServiceAreaBox
.AddItem "Anaesthesiology"
.AddItem "Cardiac"
.AddItem "Endoscopy"
.AddItem "General"
.AddItem "Gynaecologic"
.AddItem "Neurosurgery"
.AddItem "Obstetrics"
.AddItem "Oncology"
.AddItem "Ophthalmic"
.AddItem "Oral and Maxillofacial and Dentistry"
.AddItem "Orthopaedic"
.AddItem "Otolaryngic (ENT)"
.AddItem "Plastic and Reconstructive"
.AddItem "Thoracic"
.AddItem "Transplant"
.AddItem "Urologic"
.AddItem "Vascular"
.AddItem "All Other "
End With
End Sub
Private Sub UserForm_Terminate()
wsmenu.Select
End Sub
Private Sub Yes1_Click()
End Sub

Related

Combining Select Case as Cell and Range in Worksheet_Change

I have a current worksheet that needs to have values from another worksheet when values from a certain range are changed.
Also, I need to watch a certain cell value to execute another action, for this case, show a Msgbox.
I am usingWorksheet_Change(ByVal Target As Range) event but the whole code does not work when I specify Select Case "$G$6" and Case "$G$24:$H$54" and tried Case Else but did not work.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
Select Case Target.Address
Case "$G$6"
If InStr(1, Range("G6"), "PUMP") > 0 Then
MsgBox ("Pump")
ElseIf InStr(1, Range("G6"), "SKID") > 0 Then
MsgBox ("Skid")
End If
Case "$G$24:$H$54"
If Not Application.Intersect(Target, Range("G24:H54")) Is Nothing Then
If InStr(1, Range("G24"), "Calculate") > 0 And InStr(1, Range("G25"), "Outside Shelter") > 0 Then
Cells(19, 8).Value = Sheets("1").Cells(159, 6).Value
Cells(20, 9).Value = Sheets("1").Cells(163, 6).Value
Cells(19, 11).Value = Sheets("1").Cells(160, 6).Value
Cells(20, 10).Value = Sheets("1").Cells(164, 6).Value
ElseIf InStr(1, Range("G24"), "Calculate") > 0 And InStr(1, Range("G25"), "Inside Shelter") > 0 Then
Cells(19, 8).Value = Sheets("1").Cells(182, 6).Value
Cells(20, 9).Value = Sheets("1").Cells(187, 6).Value
Cells(19, 11).Value = Sheets("1").Cells(183, 6).Value
Cells(20, 10).Value = Sheets("1").Cells(188, 6).Value
End If
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Select
End Sub
This is a possible solution:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
Select Case True
Case Not Intersect(Target, Range("G6")) Is Nothing
If InStr(1, Range("G6"), "PUMP") > 0 Then
MsgBox ("Pump")
ElseIf InStr(1, Range("G6"), "SKID") > 0 Then
MsgBox ("Skid")
End If
Case Not Intersect(Target, Range("G24:H54")) Is Nothing
If InStr(1, Range("G24"), "Calculate") > 0 _
And InStr(1, Range("G25"), "Outside Shelter") > 0 Then
Cells(19, 8).Value = Sheets("1").Cells(159, 6).Value
Cells(20, 9).Value = Sheets("1").Cells(163, 6).Value
Cells(19, 11).Value = Sheets("1").Cells(160, 6).Value
Cells(20, 10).Value = Sheets("1").Cells(164, 6).Value
ElseIf InStr(1, Range("G24"), "Calculate") > 0 _
And InStr(1, Range("G25"), "Inside Shelter") > 0 Then
Cells(19, 8).Value = Sheets("1").Cells(182, 6).Value
Cells(20, 9).Value = Sheets("1").Cells(187, 6).Value
Cells(19, 11).Value = Sheets("1").Cells(183, 6).Value
Cells(20, 10).Value = Sheets("1").Cells(188, 6).Value
End If
End Select
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
The idea is use Select Case True, which selects the Not Intersect(Range1, Range2) Is Nothing. And in general, it is better to work with the Range("G6") and compare it with Target than with $G$6 and compare it with Target.Address.

pasteSpecial method of Range class failed

sometimes I don't get Excel VBA, I am just copying data from one sheet to another but I get the error :
pasteSpecial method of Range class failed
I copy some date from a source in the internet, paste it in "temporary" sheet,deleted some columns, do some calculations, and paste it into "final" sheet.
here is my code:
Sub copying()
'
' copying Macro
'
Application.Calculation = xlManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim tempSheet As Worksheet
Set tempSheet = ThisWorkbook.Sheets("temporary")
tempSheet.Activate
tempSheet.Cells.ClearFormats
tempSheet.Cells(4, 1).Select
ActiveSheet.Paste
Columns(4).Select
Selection.Cut
Columns(3).Select
ActiveSheet.Paste
Columns(6).Select
Selection.Cut
Columns(4).Select
ActiveSheet.Paste
'
Columns(7).Select
Selection.Cut
Columns(5).Select
ActiveSheet.Paste
Columns(8).Select
Selection.ClearFormats
Columns(8).Select
Selection.Cut
Columns(6).Select
ActiveSheet.Paste
Columns(9).Select
Selection.Cut
Columns(7).Select
ActiveSheet.Paste
Columns(19).Select
Selection.Cut
Columns(8).Select
ActiveSheet.Paste
Columns(21).Select
Selection.Cut
Columns(9).Select
ActiveSheet.Paste
Columns(10).Select
Selection.ClearFormats
Selection.ClearContents
Columns(73).Select
Selection.Cut
Columns(11).Select
ActiveSheet.Paste
Columns(23).Select
Selection.Cut
Columns(12).Select
ActiveSheet.Paste
Columns(25).Select
Selection.Cut
Columns(13).Select
ActiveSheet.Paste
Columns(14).Select
Selection.ClearFormats
Selection.ClearContents
Columns(37).Select
Selection.Cut
Columns(21).Select
ActiveSheet.Paste
Columns(22).Select
Selection.ClearFormats
Selection.ClearContents
Columns(76).Select
Selection.Cut
Columns(23).Select
ActiveSheet.Paste
Range("X1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.ClearContents
Columns("E:E").Select
Selection.NumberFormat = "m/d/yyyy"
Columns("F:F").Select
Selection.NumberFormat = "m/d/yyyy"
Columns("L:L").Select
Selection.NumberFormat = "0.00"
Columns("H:H").Select
Selection.NumberFormat = "0.00"
Columns(8).Select
Selection.NumberFormat = "0.00"
Columns(9).Select
Selection.NumberFormat = "0.00"
Columns(10).Select
Selection.NumberFormat = "0.00"
Columns(12).Select
Selection.NumberFormat = "0.00"
Columns(13).Select
Selection.NumberFormat = "0.00"
Columns(14).Select
Selection.NumberFormat = "0.00"
Columns(16).Select
Selection.NumberFormat = "0.00"
Columns(17).Select
Selection.NumberFormat = "0.00"
Columns(18).Select
Selection.NumberFormat = "0.00"
Columns(20).Select
Selection.NumberFormat = "0.00"
Columns(21).Select
Selection.NumberFormat = "0.00"
Columns(22).Select
Selection.NumberFormat = "0.00"
' Debug.Print Cells(10, 2)
lrow = Cells(Rows.Count, "C").End(xlUp).row
'debig.Print Cells(2, 9).Value
Dim i As Integer
For i = 5 To lrow
' calculating the UM = NS - CoS
'for SDP3
If (Cells(i, 8).Value = "Missing Data" Or Cells(i, 9).Value = "Missing Data") Then
Cells(i, 10).Value = "Missing Data"
Else
Cells(i, 10).Value = Cells(i, 8).Value - Cells(i, 9).Value
End If
'TG2
If (Cells(i, 12).Value = "Missing Data" Or Cells(i, 13).Value = "Missing Data") Then
Cells(i, 14).Value = "Missing Data"
Else
Cells(i, 14).Value = Cells(i, 12).Value - Cells(i, 13).Value
End If
' PTD
If (Cells(i, 16).Value = "Missing Data" Or Cells(i, 17).Value = "Missing Data") Then
Cells(i, 18).Value = "Missing Data"
Else
Cells(i, 18).Value = Cells(i, 16).Value - Cells(i, 17).Value
End If
' PTE
If (Cells(i, 20).Value = "Missing Data" Or Cells(i, 21).Value = "Missing Data") Then
Cells(i, 22).Value = "Missing Data"
Else
Cells(i, 22).Value = Cells(i, 20).Value - Cells(i, 21).Value
End If
'%UM DEVIATION = UM% of the second - UM%
'SDP3 --- TG2
If (Cells(i, "K").Value = "N/A" Or Cells(i, "O").Value = "N/A") Then
Cells(i, "Y").Value = "N/A"
Else
Cells(i, "Y").Value = Cells(i, "O").Value - Cells(i, "K").Value
End If
'SDP3 --- PTE
If (Cells(i, "K").Value = "N/A" Or Cells(i, "S").Value = "N/A") Then
Cells(i, "AB").Value = "N/A"
Else
Cells(i, "AB").Value = Cells(i, "S").Value - Cells(i, "K").Value
End If
'TG2 -- PTE
If (Cells(i, "O").Value = "N/A" Or Cells(i, "S").Value = "N/A") Then
Cells(i, "AE").Value = "N/A"
Else
Cells(i, "AE").Value = Cells(i, "S").Value - Cells(i, "O").Value
End If
' DEV MSEK if (UM% of both < 0 -> %UM * NS of the second)
'SDP3 --- TG2
If (Cells(i, "Y").Value = "N/A" Or Cells(i, "L").Value = "N/A") Then
Cells(i, "X").Value = "N/A"
Else
If (Cells(i, "Y").Value < 0) Then
Cells(i, "X").Value = 0
Else
Cells(i, "X").Value = Cells(i, "Y").Value * Cells(i, "L").Value
End If
End If
'SDP3 --- PTE
If (Cells(i, "AB").Value = "N/A" Or Cells(i, "P").Value = "N/A") Then
Cells(i, "AA").Value = "N/A"
Else
If (Cells(i, "AB").Value < 0) Then
Cells(i, "AA").Value = 0
Else
Cells(i, "AA").Value = Cells(i, "AB").Value * Cells(i, "P").Value
End If
End If
'TG2 -- PTE
If (Cells(i, "AE").Value = "N/A" Or Cells(i, "P").Value = "N/A") Then
Cells(i, "AD").Value = "N/A"
Else
If (Cells(i, "AE").Value < 0) Then
Cells(i, "AD").Value = 0
Else
Cells(i, "AD").Value = Cells(i, "AE").Value * Cells(i, "P").Value
End If
End If
' indicators Y,AB,AE - > Z, AC , AF
If (Cells(i, "Y").Value = "N/A") Then
Cells(i, "Z").Value = "N/A"
Else
If (Cells(i, "Y").Value < 0) Then
Cells(i, "Z").Value = Chr(226)
Cells(i, "Z").Font.Name = "Wingdings"
Cells(i, "Z").Font.Color = vbRed
ElseIf (Cells(i, "Y").Value > 0) Then
Cells(i, "Z").Value = Chr(225)
Cells(i, "Z").Font.Name = "Wingdings"
Cells(i, "Z").Font.Color = vbGreen
Else
Cells(i, "Z").Value = "-"
End If
End If
If (Cells(i, "AB").Value = "N/A") Then
Cells(i, "AC").Value = "N/A"
Else
If (Cells(i, "AB").Value < 0) Then
Cells(i, "AC").Value = Chr(226)
Cells(i, "AC").Font.Name = "Wingdings"
Cells(i, "AC").Font.Color = vbRed
ElseIf (Cells(i, "AB").Value > 0) Then
Cells(i, "AC").Value = Chr(225)
Cells(i, "AC").Font.Name = "Wingdings"
Cells(i, "AC").Font.Color = vbGreen
Else
Cells(i, "AC").Value = "-"
End If
End If
If (Cells(i, "AE").Value = "N/A") Then
Cells(i, "AF").Value = "N/A"
Else
If (Cells(i, "AE").Value < 0) Then
Cells(i, "AF").Value = Chr(226)
Cells(i, "AF").Font.Name = "Wingdings"
Cells(i, "AF").Font.Color = vbRed
ElseIf (Cells(i, "AE").Value > 0) Then
Cells(i, "AF").Value = Chr(225)
Cells(i, "AF").Font.Name = "Wingdings"
Cells(i, "AF").Font.Color = vbGreen
Else
Cells(i, "AF").Value = "-"
End If
End If
Next
' format the columns
Columns("Y:Y").Select
Selection.NumberFormat = "0.00%"
Columns("AB:AB").Select
Selection.NumberFormat = "0.00%"
Columns("AE:AE").Select
Selection.NumberFormat = "0.00%"
ActiveSheet.Range("A5:AF" & lrow).Copy
ThisWorkbook.Worksheets("final").Activate
Application.Wait (Now + TimeValue("0:00:01"))
lrowFinal = Cells(Rows.Count, "C").End(xlUp).row
If lrowFinal < 4 Then
lrowFinal = 4
End If
ThisWorkbook.Sheets("final").Range("C3:AH" & lrowFinal).ClearContents
ThisWorkbook.Sheets("final").Range("C4").PasteSpecial (Excel.XlPasteType.xlPasteAll)
'ActiveSheet.PasteSpecial Paste:=xlPasteValues
'PasteAsLocalFormula
Application.CutCopyMode = False
With ActiveSheet
.AutoFilterMode = False
.Range("C4").CurrentRegion.AutoFilter
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
the error happens a few lines at the end at:
ThisWorkbook.Sheets("final").Range("C4").PasteSpecial (Excel.XlPasteType.xlPasteAll)
what did I do wrong, I tried many fixes but none worked
EDIT:
I changed the copying code to the following but I am still getting the error:
ThisWorkbook.Sheets("final").Activate
Application.Wait (Now + TimeValue("0:00:01"))
lrowFinal = Cells(Rows.Count, "C").End(xlUp).row
If lrowFinal < 4 Then
lrowFinal = 4
End If
ActiveSheet.Range("C3:AH" & lrowFinal).ClearContents
Sheets("temporary").Activate
ActiveSheet.Range("A5:AF" & lrow).Copy
ThisWorkbook.Worksheets("final").Activate
ActiveSheet.Range("C4").PasteSpecial xlPasteAll

How do I make the VBA macro repeat for all worksheets (tech collect1..2..etc) except for Tech Database which is where the info will paste to?

The first section is where I am copying the data from and the second section is where I am pasting the data to. Multiple worksheets will be added to the workbook ( tech collect) so when i run the code it should copy all info from "tech collect" to "tech database"
Sub Test()
'
' Test Macro
' test
'
' Keyboard Shortcut: Ctrl+a
'
Sheets("Technician Collection").Select
Range("B3").Select
Sheets("Tech Collection Database").Select
Range("B6").Select
Sheets("Technician Collection").Select
xb3 = (ActiveCell.Value)
xb4 = (ActiveCell.Offset(1, 0).Value)
xb5 = (ActiveCell.Offset(2, 0).Value)
xb6 = (ActiveCell.Offset(3, 0).Value)
xb7 = (ActiveCell.Offset(4, 0).Value)
xb8 = (ActiveCell.Offset(5, 0).Value)
xb9 = (ActiveCell.Offset(6, 0).Value)
xb10 = (ActiveCell.Offset(7, 0).Value)
xb11 = (ActiveCell.Offset(8, 0).Value)
xb12 = (ActiveCell.Offset(9, 0).Value)
xb15 = (ActiveCell.Offset(12, 0).Value)
xb16 = (ActiveCell.Offset(13, 0).Value)
xb17 = (ActiveCell.Offset(14, 0).Value)
xb18 = (ActiveCell.Offset(15, 0).Value)
xb19 = (ActiveCell.Offset(16, 0).Value)
xb20 = (ActiveCell.Offset(17, 0).Value)
xb21 = (ActiveCell.Offset(18, 0).Value)
xb22 = (ActiveCell.Offset(19, 0).Value)
xb24 = (ActiveCell.Offset(21, 0).Value)
xc24 = (ActiveCell.Offset(21, 1).Value)
xd24 = (ActiveCell.Offset(21, 2).Value)
xe24 = (ActiveCell.Offset(21, 3).Value)
xb25 = (ActiveCell.Offset(22, 0).Value)
xb26 = (ActiveCell.Offset(23, 0).Value)
xc26 = (ActiveCell.Offset(23, 1).Value)
xd26 = (ActiveCell.Offset(23, 2).Value)
xe26 = (ActiveCell.Offset(23, 3).Value)
xb27 = (ActiveCell.Offset(24, 0).Value)
xc27 = (ActiveCell.Offset(24, 1).Value)
xd27 = (ActiveCell.Offset(24, 2).Value)
xe27 = (ActiveCell.Offset(24, 3).Value)
xb28 = (ActiveCell.Offset(25, 0).Value)
xc28 = (ActiveCell.Offset(25, 1).Value)
xd28 = (ActiveCell.Offset(25, 2).Value)
xe28 = (ActiveCell.Offset(25, 3).Value)
xb30 = (ActiveCell.Offset(27, 0).Value)
xc30 = (ActiveCell.Offset(27, 1).Value)
xd30 = (ActiveCell.Offset(27, 2).Value)
xe30 = (ActiveCell.Offset(27, 3).Value)
xb32 = (ActiveCell.Offset(29, 0).Value)
xb34 = (ActiveCell.Offset(31, 0).Value)
xb36 = (ActiveCell.Offset(33, 0).Value)
xb40 = (ActiveCell.Offset(37, 0).Value)
xb41 = (ActiveCell.Offset(38, 0).Value)
xb42 = (ActiveCell.Offset(39, 0).Value)
xb43 = (ActiveCell.Offset(40, 0).Value)
xb44 = (ActiveCell.Offset(41, 0).Value)
xb45 = (ActiveCell.Offset(42, 0).Value)
xb46 = (ActiveCell.Offset(43, 0).Value)
xb47 = (ActiveCell.Offset(44, 0).Value)
xb48 = (ActiveCell.Offset(45, 0).Value)
Sheets("Tech Collection Database").Select
ActiveCell.Value = xb3
ActiveCell.Offset(0, 1).Value = xb4
ActiveCell.Offset(0, 2).Value = xb5
ActiveCell.Offset(0, 3).Value = xb6
ActiveCell.Offset(0, 4).Value = xb7
ActiveCell.Offset(0, 5).Value = xb8
ActiveCell.Offset(0, 6).Value = xb9
ActiveCell.Offset(0, 7).Value = xb10
ActiveCell.Offset(0, 8).Value = xb11
ActiveCell.Offset(0, 9).Value = xb12
ActiveCell.Offset(0, 10).Value = xb15
ActiveCell.Offset(0, 11).Value = xb16
ActiveCell.Offset(0, 12).Value = xb17
ActiveCell.Offset(0, 13).Value = xb18
ActiveCell.Offset(0, 14).Value = xb19
ActiveCell.Offset(0, 15).Value = xb20
ActiveCell.Offset(0, 16).Value = xb21
ActiveCell.Offset(0, 17).Value = xb22
ActiveCell.Offset(0, 18).Value = xb24
ActiveCell.Offset(0, 19).Value = xc24
ActiveCell.Offset(0, 20).Value = xd24
ActiveCell.Offset(0, 21).Value = xe24
ActiveCell.Offset(0, 22).Value = xb25
ActiveCell.Offset(0, 23).Value = xb26
ActiveCell.Offset(0, 24).Value = xc26
ActiveCell.Offset(0, 25).Value = xd26
ActiveCell.Offset(0, 26).Value = xe26
ActiveCell.Offset(0, 27).Value = xb27
ActiveCell.Offset(0, 28).Value = xc27
ActiveCell.Offset(0, 29).Value = xd27
ActiveCell.Offset(0, 30).Value = xe27
ActiveCell.Offset(0, 31).Value = xb28
ActiveCell.Offset(0, 32).Value = xc28
ActiveCell.Offset(0, 33).Value = xd28
ActiveCell.Offset(0, 34).Value = xe28
ActiveCell.Offset(0, 35).Value = xb30
ActiveCell.Offset(0, 36).Value = xc30
ActiveCell.Offset(0, 37).Value = xd30
ActiveCell.Offset(0, 38).Value = xe30
ActiveCell.Offset(0, 39).Value = xb32
ActiveCell.Offset(0, 40).Value = xb34
ActiveCell.Offset(0, 41).Value = xb36
ActiveCell.Offset(0, 42).Value = xb40
ActiveCell.Offset(0, 43).Value = xb41
ActiveCell.Offset(0, 44).Value = xb42
ActiveCell.Offset(0, 45).Value = xb43
ActiveCell.Offset(0, 46).Value = xb44
ActiveCell.Offset(0, 47).Value = xb45
ActiveCell.Offset(0, 48).Value = xb46
ActiveCell.Offset(0, 49).Value = xb47
ActiveCell.Offset(0, 50).Value = xb48
End Sub
The first section is where I am copying the data from and the second section is where I am pasting the data to
This is what I have used to step though every sheet except for one:
For Each Sh In MyWkBk.Sheets
If Sh.Name <> "Reference" Then
'....
'Your Code Here
'....
End If
Next

VBA Excel: Dialog window opens when referring to cell in different worksheet

I'm breaking my head over this one and I hope someone can help. I have a procedure that adds a new worksheet into an Excel workbook and adds basic information of this worksheet into an overview in another worksheet (same workbook). It all works fine as it should, but unfortunately with one exception. There is one cell that should have the value of a cell in the newly created Worksheet. I've used this line for it:
c.Offset(0, 27).Value = "=" & Left(AccName.Value, 20) & "!N16"
Here the "Left(AccName.value,20)" equals the worksheet name. Unfortunately here the code opens a dialog window where I can open a file. I have no idea why and thus no idea how I can fix this. Does anybody here have any idea?
Edit: Here's the entire sub:
Sub FillBestandsübersicht()
Dim c As Range
Dim i As Integer
i = 3
'Find next empty row
Set c = Sheets("Bestandsübersicht").Range("A3")
Do Until c.Value = ""
Set c = c.Offset(1, 0)
i = i + 1
Loop
'Fill Bestandsübersicht
c.Value = AccName.Value
c.Offset(0, 1).Value = ProgRef.Value
c.Offset(0, 2).Value = QuoteNr.Value
c.Offset(0, 3).Value = PolicyNr.Value
If LdrY.Value = True Or LocY.Value = False Then c.Offset(0, 4).Value = "n.a."
c.Offset(0, 5).Value = ddUnderwriters.Value
c.Offset(0, 6).Value = IncDate.Value
c.Offset(0, 7).Value = ExpDate.Value
If LdrY.Value = True Then
c.Offset(0, 8).Value = "Lead"
Else
c.Offset(0, 8).Value = "Follow"
End If
c.Offset(0, 10).Value = PMNPL.Value
If LdrY.Value = True And LocY.Value = True Then
c.Offset(0, 11).Value = AmountLoc.Value
Else
c.Offset(0, 11).Value = 0
End If
If CoiY.Value = True Then
c.Offset(0, 12).Value = AmountCOI.Value
Else
c.Offset(0, 12).Value = 0
End If
c.Offset(0, 14).Value = "n"
c.Offset(0, 15).Value = "n"
If DocY.Value = False Then c.Offset(0, 16).Value = "x" Else c.Offset(0, 16).Value = "n"
If LdrY.Value = False Or LocY.Value = False Or CoiY.Value = False Then _
c.Offset(0, 17).Value = "x" Else c.Offset(0, 17).Value = "n"
If FacY.Value = False Then c.Offset(0, 18).Value = "x" Else c.Offset(0, 18).Value = "n"
If LdrY.Value = True Or LocY.Value = False Then c.Offset(0, 19).Value = "x" Else c.Offset(0, 19).Value = "n"
If LdrY.Value = False Or LocY.Value = False Then c.Offset(0, 20).Value = "x" Else c.Offset(0, 20).Value = "n"
c.Offset(0, 21).Value = "n"
c.Offset(0, 26).Value = Left(AccName.Value, 20)
c.Offset(0, 27).Value= "=" & Left(AccName.Value, 20) & "!N16"
'Sort Bestandsübersicht
Range("A3:AB10000").Sort key1:=Range("A3:A10000"), order1:=xlAscending, Header:=xlNo
'AutoFit rows
Sheets("Bestandsübersicht").Rows("3:" & i).EntireRow.autofit
End Sub
I think there is no sheet within your workbook which name equals to result of this function/calculation: Left(AccName.Value, 20)

input from vba form overwriting rows

I have a vba form which inputs the data gathered into one my sheets in my workbook. It is designed (supposed to be) so it will find the last empty row and then input the new information. It worked for the first 60 rows but now it keeps overwriting the existing information in row 60 and will not go further. Any ideas will help because I can't see anything that would stop it at row 60.
Sub UserForm_Initialize()
ComboBoxWellNameW1.List = Array("4-14-820", "5-56-820", "9-41-820", "10-30-820", "16-31-820", "16-12-820", "16-11-820", "10-42-820", "10-31-820", "10-32-820")
ComboBoxWellStatusW1.List = Array("Pumping", "Shut-in", "Flowing", "Work-over")
ComboBoxTagW1.List = Array("Yes", "No", "N/A")
ComboBoxStrokesW1.List = Array("3", "3.5", "4", "4.5", "5", "5.5", "6", "6.5", "7", "7.5", "8", "8.5", "9")
ComboBoxGauger.List = Array("Jim Burns", "Adam Miller")
TextBoxDate.Value = Date
ComboBoxTime.List = Array("0:00", "0:15", "0:30", "0:45", "1:00", "1:15", "1:30", "1:45", "2:00", "2:15", "2:30", "2:45", "3:00", "3:15", "3:30", "3:45", "4:00", "4:15", "4:30", "4:45", "5:00", "5:15", "5:30", "5:45", "6:00", "6:15", "6:30", "6:45", "7:00", "7:15", "7:30", "7:45", "8:00", "8:15", "8:30", "8:45", "9:00", "9:15", "9:30", "9:45", "10:00", "10:15", "10:30", "10:45", "11:00", "11:15", "11:30", "11:45", "12:00", "12:15", "12:30", "12:45", "13:00", "13:15", "13:30", "13:45", "14:00", "14:15", "14:30", "14:45", "15:00", "15:15", "15:30", "15:45", "16:00", "16:15", "16:30", "16:45", "17:00", "17:15", "17:30", "17:45", "18:00", "18:15", "18:30", "18:45", "19:00", "19:15", "19:30", "19:45", "20:00", "20:15", "20:30", "20:45", "21:00", "21:15", "21:30", "21:45", "22:00", "22:15", "22:30", "22:45", "23:00", "23:15", "23:30", "23:45")
DailyGaugeSheet.Show
End Sub
Sub commandButtonSubmit_Click()
With ThisWorkbook.Sheets("Results")
.Range("C5000").Select
Selection.End(xlUp).Select
ActiveCell.Offset(0).Select
ActiveCell.Value = TextBoxDate
ActiveCell.Offset(0, 1).Value = ComboBoxTime
ActiveCell.Offset(0, 2).Value = ComboBoxGauger
ActiveCell.Offset(0, 3).Value = ComboBoxWellNameW1
ActiveCell.Offset(0, 4).Value = ComboBoxWellStatusW1
ActiveCell.Offset(0, 5).Value = TextBoxTK1FtW1
ActiveCell.Offset(0, 6).Value = TextBoxTK1InchW1
ActiveCell.Offset(0, 7).Value = TextBoxTK2FtW1
ActiveCell.Offset(0, 8).Value = TextBoxTK2InchW1
ActiveCell.Offset(0, 9).Value = TextBoxTK3FtW1
ActiveCell.Offset(0, 10).Value = TextBoxTK3InchW1
ActiveCell.Offset(0, 11).Value = TextBoxTK4FtW1
ActiveCell.Offset(0, 12).Value = TextBoxTK4InchW1
ActiveCell.Offset(0, 13).Value = TextBoxTK5FtW1
ActiveCell.Offset(0, 14).Value = TextBoxTK5InchW1
ActiveCell.Offset(0, 15).Value = TextBoxTK1WaterHauled
ActiveCell.Offset(0, 16).Value = TextBoxTK2WaterHauled
ActiveCell.Offset(0, 17).Value = TextBoxTK3WaterHauled
ActiveCell.Offset(0, 18).Value = TextBoxTK4WaterHauled
ActiveCell.Offset(0, 19).Value = TextBoxTK5WaterHauled
ActiveCell.Offset(0, 20).Value = TextBoxTK1OilHauled
ActiveCell.Offset(0, 21).Value = TextBoxTK2OilHauled
ActiveCell.Offset(0, 22).Value = TextBoxTK3OilHauled
ActiveCell.Offset(0, 23).Value = TextBoxTK4OilHauled
ActiveCell.Offset(0, 24).Value = TextBoxTK5OilHauled
ActiveCell.Offset(0, 30).Value = TextBoxTubingW1
ActiveCell.Offset(0, 31).Value = TextBoxCasingW1
ActiveCell.Offset(0, 32).Value = ComboBoxTagW1
ActiveCell.Offset(0, 33).Value = ComboBoxStrokesW1
ActiveCell.Offset(0, 34).Value = TextBoxChokeW1
ActiveCell.Offset(0, 37).Value = TextBoxTrTempW1
ActiveCell.Offset(0, 38).Value = TextBoxTrPressW1
ActiveCell.Offset(0, 39).Value = TextBoxStaticPr
ActiveCell.Offset(0, 40).Value = TextBoxDiffPr
ActiveCell.Offset(0, 41).Value = TextBoxYestGasVol
ActiveCell.Offset(0, 42).Value = TextBoxCommentsW1
ActiveCell.Offset(0, 43).Value = TextBoxPumpIntake
ActiveCell.Offset(0, 44).Value = TextBoxPumpTemp
ActiveCell.Offset(0, 45).Value = TextBoxPumpHZ
ActiveCell.Offset(0, 46).Value = TextBoxDownTime
ActiveCell.Offset(0, 47).Value = TextBoxFluidLevel
ComboBoxTime = ""
ComboBoxWellNameW1 = ""
ComboBoxWellStatusW1 = ""
TextBoxTK1FtW1 = ""
TextBoxTK1InchW1 = ""
TextBoxTK2FtW1 = ""
TextBoxTK2InchW1 = ""
TextBoxTK3FtW1 = ""
TextBoxTK3InchW1 = ""
TextBoxTK4FtW1 = ""
TextBoxTK4InchW1 = ""
TextBoxTK5FtW1 = ""
TextBoxTK5InchW1 = ""
TextBoxTK1WaterHauled = ""
TextBoxTK2WaterHauled = ""
TextBoxTK3WaterHauled = ""
TextBoxTK4WaterHauled = ""
TextBoxTK5WaterHauled = ""
TextBoxTK1OilHauled = ""
TextBoxTK2OilHauled = ""
TextBoxTK3OilHauled = ""
TextBoxTK4OilHauled = ""
TextBoxTK5OilHauled = ""
TextBoxTubingW1 = ""
TextBoxCasingW1 = ""
ComboBoxTagW1 = ""
ComboBoxStrokesW1 = ""
TextBoxChokeW1 = ""
TextBoxTrTempW1 = ""
TextBoxTrPressW1 = ""
TextBoxStaticPr = ""
TextBoxDiffPr = ""
TextBoxYestGasVol = ""
TextBoxCommentsW1 = ""
TextBoxPumpIntake = ""
TextBoxPumpTemp = ""
TextBoxPumpHZ = ""
TextBoxDownTime = ""
TextBoxFluidLevel = ""
End With
End Sub
Replace
.Range("C5000").Select
Selection.End(xlUp).Select
ActiveCell.Offset(0).Select
with
Y = ActiveSheet.UsedRange.Rows.Count
lastRow = ActiveCell.SpecialCells(xlLastCell).Row
.Cells(lastRow, "C").Select
Try changing this:
.Range("C5000").Select
Selection.End(xlUp).Select
ActiveCell.Offset(0).Select
To just this:
.Range("C" & .Rows.Count).End(xlUp).Offset(1,0).Select
The Offset(1,0) is absolutely necessary to get the next empty row. Otherwise, you are just targeting your last row again and again.
Also, quit using ActiveCell and Select. They're honestly crappy methods. Check this post for some ideas: Can I make this macro more efficient or faster? Check #4. It should give you an idea on how to tackle this better.
Let us know if this helps.