I would love to optimize this code so that it executes faster...
Sub gotocfstatement()
If ActiveCell.Row < 10 Then Exit Sub
If ActiveCell.Row > 5001 Then Exit Sub
If Sheet1.Range("p" & (ActiveCell.Row)).Value = "" Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Filename = Sheet1.Range("p" & (ActiveCell.Row)).Value
Sheet2.Range("b9").Value = Filename
If Sheet2.Range("b15").Value = "" Then
Sheet2.Range("b14").Value = Sheet2.Range("s1").Value
Else
Sheet2.Range("b14").Value = Sheet2.Range("b15").Value
End If
If Sheet2.Range("a81").Value = "" Then
Sheet2.Range("a85").Value = Sheet2.Range("ab1").Value
Else
Sheet2.Range("a85").Value = Sheet2.Range("a81").Value
End If
Sheets("cash flow statement").Select
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub
Related
I've been trying to program a special user login and Audit Trail, the login makes sheets display in custom order, then I still get
Error 1004: Method of Visible Object Failed.
Help me please :(
Macro 1 (I have 5 sheets in this book, each one has this macro in them):
Private Sub Worksheet_Deactivate()
Me.Name = "Información"
ThisWorkbook.Protect , True
Application.OnTime Now, "UnprotectBook"
End Sub
And Have this one in This Workbook:
Private Sub Workbook_Open()
Application.Visible = False
Sheet1.Visible = True
Sheet2.Visible = False
Sheet3.Visible = False
Sheet4.Visible = False
Sheet5.Visible = False
UF_log.Show
End Sub
Private Sub Workbook_Close()
Sheet1.Visible = False
Sheet2.Visible = False
Sheet3.Visible = False
Sheet4.Visible = False
Sheet5.Visible = False
End Sub
Private Sub Workbook_NewSheet(ByVal Sh As Object)
Application.DisplayAlerts = False
ActiveSheet.Delete
MsgBox "No se tiene permitido insertar nuevas hojas de cálculo", vbExclamation, "Alerta"
Application.DisplayAlerts = True
End Sub
UF log code:
Private Sub EnterButton_Click()
Dim Fila, final As Integer
Dim password As Variant
Dim DatoEncontrado
UsuarioExistente = Application.WorksheetFunction.CountIf(Sheets("Users").Range("A:A"), _
Me.TxtUser.Value)
Set Rango = Sheets("Users").Range("A:A")
If Trim(TxtUser.Text) = "" Then
MsgBox "Ingreso Usuario", vbExclamation, "Alerta"
TxtUser.SetFocus
Exit Sub
End If
If Trim(TxtPassword.Text) = "" Then
MsgBox "Ingreso Contraseña", vbExclamation, "Alerta"
TxtPassword.SetFocus
Exit Sub
End If
If UsuarioExistente = 0 Then
MsgBox "El usuario '" & Me.TxtUser & "' no existe", vbExclamation, "Alerta"
Exit Sub
End If
If UsuarioExistente = 1 Then
DatoEncontrado = Rango.Find(What:=Me.TxtUser.Value, MatchCase:=True).Address
Contra = CStr(Sheets("Users").Range(DatoEncontrado).Offset(0, 1).Value)
Estatus = CStr(Sheets("Users").Range(DatoEncontrado).Offset(0, 2).Value)
If Sheets("Users").Range(DatoEncontrado).Value = Me.TxtUser.Value And Contra = Me.TxtPassword.Value Then
MsgBox "Acceso correcto", vbExclamation, "Ok"
If Estatus = "Administrador" Then
Application.Visible = True
Sheet1.Visible = True
Sheet2.Visible = True
Sheet3.Visible = True
Sheet4.Visible = True
Sheet5.Visible = True
Application.CommandBars("Ply").Enabled = True
Call Desproteger
For Fila = 1 To 1000
If Sheet4.Cells(Fila, 1) = "" Then
final = Fila
Exit For
End If
Next
Sheet4.Cells(final, 1) = Application.UserName & " accessed via log in " & " at " & Time & " " & Date
Call Proteger
End
Else
If Estatus = "Fabricación" Then
Application.Visible = True
Sheet1.Visible = True
Sheet2.Visible = xlSheetVeryHidden
Sheet3.Visible = True
Sheet4.Visible = True
Sheet5.Visible = xlSheetVeryHidden
Application.CommandBars("Ply").Enabled = True
Call Desproteger
For Fila = 1 To 1000
If Sheet4.Cells(Fila, 1) = "" Then
final = Fila
Exit For
End If
Next
Sheet4.Cells(final, 1) = Application.UserName & " accessed via log in " & " at " & Time & " " & Date
Call Proteger
End
Else
Application.Visible = True
Sheet1.Visible = True
Sheet2.Visible = True
Sheet3.Visible = xlSheetVeryHidden
Sheet4.Visible = True
Sheet5.Visible = xlSheetVeryHidden
Application.CommandBars("Ply").Enabled = False
Call Desproteger
For Fila = 1 To 1000
If Sheet4.Cells(Fila, 1) = "" Then
final = Fila
Exit For
End If
Next
Sheet4.Cells(final, 1) = Application.UserName & " accessed via log in " & " at " & Time & " " & Date
Call Proteger
End
End If
End If
Else
MsgBox "Datos incorrectos, vuelva a intentar", vbExclamation, "Error"
End If
End If
End Sub
Private Sub ExitButton_Click()
End
End Sub
Code that searches for duplicates works in test mode, but doesn't when I run it normally.
I have a subroutine called FindDuplicatesInColumn, placed in the section that Validates data entered into a userform.
' Check if all data has been entered on the userform
Function Data_Validation() As Boolean 'Declare Function with Bool as data type
'Default True. False if any conditions met. When a function is called, a new variable,
'with the function name and datatype given is created. You'll set the value in the
'function. When the function ends either in Exit Function or
'End Function, whatever is contained in this variable is returned as the Functions result
Data_Validation = True
' Check if all data has been entered on the userform
If ARLArea = False And KNBArea = False And LSQArea = False And RSQArea = False And RevenueControlInspectors = False And SpecialRequirementTeam = False Then
MsgBox "Select Area!", vbInformation, ("Area")
ARLArea.SetFocus
Data_Validation = False
Exit Function
End If
If EmployeeNo1 = "" Then
MsgBox "Enter Employee Number!", vbInformation, ("Employee Number")
EmployeeNo1.SetFocus
Data_Validation = False
Exit Function
End If
If FirstName1 = "" Then
MsgBox "Enter First Name!", vbInformation, ("First Name")
FirstName1.SetFocus
Data_Validation = False
Exit Function
End If
If LastName1 = "" Then
MsgBox "Enter Last Name!", vbInformation, ("Last Name")
LastName1.SetFocus
Data_Validation = False
Exit Function
End If
If CSA2 = False And CSA1 = False And CSS2 = False And CSS1 = False And CSM2 = False And CSM1 = False And AM = False And RCI = False And SRT = False Then
MsgBox "Select Grade!", vbInformation, ("Grade")
CSA2.SetFocus
Data_Validation = False
Exit Function
End If
BlnVal = 1
FindDuplicatesInColumn
End Function
The Subroutine I created
Sub FindDuplicatesInColumn()
Dim sAccNum As String
Dim rAccLst As Range
Dim res
Dim IdVal As Integer
Set rAccLst = Sheets("Data Input").Range("B5:B" & Range("B" & Rows.Count).End(xlUp).Row)
sAccNum = EmployeeNo1
If Not rAccLst.Find(What:=sAccNum, LookIn:=xlValues, Lookat:=xlPart) Is Nothing Then
MsgBox "Sorry, This person already exists in the Database!"
'Empty Area
ARLArea = False
LSQArea = False
KNBArea = False
RSQArea = False
RevenueControlInspectors = False
SpecialRequirementTeam = False
'Empty EmployeeNo1
EmployeeNo1.Value = ""
'Empty FirstName1
FirstName1.Value = ""
'Empty LastName1
LastName1.Value = ""
'Empty Grade
CSA2 = False
CSA1 = False
CSS2 = False
CSS1 = False
CSM2 = False
CSM1 = False
AM = False
RCI = False
SRT = False
sAccNum = ""
If Data_Validation() = False Then
Exit Sub
End If
Else
'Sheets("Data Input").Range("B" & Range("B" & Rows.Count).End(xlUp).Row).Offset(1, 0).Value = "ACC" & sAccNum
End If
End Sub
I am trying to check when the user enters the EmployeeNo1 in the userform. It is checked against the data in Column B of Data_Input to see if it is duplicated. If it is, then to stop the data from the form being added to the database.
Set rAccLst = Sheets("Data Input").Range("B5:B" & Range("B" & Rows.Count).End(xlUp).Row)
should be
With Sheets("Data Input")
Set rAccLst = .Range("B5:B" & .Range("B" & .Rows.Count).End(xlUp).Row)
End with
...otherwise that second Range() defaults to the active sheet and not necessarily to the sheet you want.
Whenever I run this code, it generates a sequential number.
I want to display the new sequential number in a MsgBox, but it prints the older sequential number.
Private Sub ToggleButton1_Click()
Dim reponse As VbMsgBoxResult
Dim REVISIONRNCAUTO As Workbook
Dim Sheet2 As Worksheet
Dim cell_value As String
Set REVISIONRNCAUTO = ActiveWorkbook
Set Sheet2 = REVISIONCRNAUTO.Worksheets(2)
cell_value = Sheet2.Cells(4, "A").Value & Sheet2.Cells(4, "B").Value
If CheckBox1.Value = True And CheckBox4.Value = True And CheckBox7.Value = True And CheckBox2.Value = False And CheckBox3.Value = False _
And CheckBox6.Value = False And CheckBox5.Value = False And CheckBox8.Value = False And CheckBox9.Value = False And CheckBox10.Value = False And CheckBox11.Value = False And CheckBox12.Value = False _
And CheckBox13.Value = False And CheckBox14.Value = False And CheckBox15.Value = False Then
Sheet2.Activate
reponse = MsgBox("Êtes-vous sûr de vouloir générer ce RNC?", vbYesNo + vbQuestion, "Enregistrement RNC")
If reponse = vbYes Then
Sheets("Sheet2").Range("B4").Select
ActiveCell.EntireRow.Insert shift:=xlDown
Sheets("Sheet2").Range("B4:E4").Select
Selection.Borders.Weight = xlThin
Sheets("Sheet2").Range("B4").Select
ActiveCell.Value = "=b5+1"
Sheets("Sheet2").Range("A4").Select
Selection.Borders.Weight = xlThin
ActiveCell.Value = "E"
Else
Exit Sub
End If
End If
MsgBox ("Le nouveau RNC enregistré est le : " & cell_value)
You aren't changing the value of cell_value after you set it.
They are not linked forever like an Excel formula. You have to set it again once you change the cells that it is based on.
Put the cell_value = line right before the Else in addition to where it currently is.
ive looked through other posts and I can't quite figure out the day picker for my user form. Any ideas or help would be appreciated. The input date box is currently just a text box to write in the date in the format dd-mmm-yy. As ive been testing the form it's pretty hard to type the date in like this. Since I built the form for someone else I would like it to be a little easier. Thanks
Private Sub UserForm_Initialize()
'Empty TextBox
DateTextBox.Value = ""
CmbBox_ACFT.Value = ""
JCNTextBox.Value = ""
TEMSTextBox.Value = ""
DMGTextBox.Value = ""
MXNTextBox.Value = ""
CmbBox_POS.Clear
CmbBox_Shift.Clear
With CmbBox_Shift
CmbBox_Shift.AddItem "DAYS"
CmbBox_Shift.AddItem "SWINGS"
CmbBox_Shift.AddItem "MIDS"
End With
With CmbBox_POS
CmbBox_POS.AddItem "1"
CmbBox_POS.AddItem "2"
CmbBox_POS.AddItem "APU"
End With
With CmbBox_ACFT
CmbBox_ACFT.AddItem "123"
CmbBox_ACFT.AddItem "456"
CmbBox_ACFT.AddItem "789"
CmbBox_ACFT.AddItem "012"
CmbBox_ACFT.AddItem "782"
End With
Option_Yes.Value = False
DateTextBox.SetFocus
End Sub
Sub OKButton_Click()
Dim emptyRow As Long
'Make Sheet1 active
Sheet1.Activate
'Determine emptyRow
emptyRow = WorksheetFunction.CountA(Range("A:A")) + 1
'Transfer information
Cells(emptyRow, 1).Value = DateTextBox.Value 'need a date picker to help minimize errors. In dd-mmm-yy format.
Cells(emptyRow, 2).Value = CmbBox_ACFT.Value
Cells(emptyRow, 3).Value = CmbBox_Shift.Value
Cells(emptyRow, 4).Value = CmbBox_POS.Value
Cells(emptyRow, 5).Value = MXNTextBox.Value
Cells(emptyRow, 6).Value = JCNTextBox.Value
Cells(emptyRow, 7).Value = TEMSTextBox.Value
'Cells(emptyRow, 8).Value = DinnerComboBox.Value
Cells(emptyRow, 9).Value = DMGTextBox.Value
If Option_Yes.Value = True Then
Cells(emptyRow, 8).Value = "Yes"
Else
Cells(emptyRow, 8).Value = "No"
End If
With ActiveSheet.UsedRange.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End Sub
it is entirely possible the date picker control may not be installed. I did find a related post that explains how to ensure it is installed ("Monthview"). You have to install it.
First close Excel.
download MSCOMCT2.cab from http://support.microsoft.com/kb/297381 and extract the two files inside the zip file.
Right click the .inf file and click "Install".
Next, open Windows Explorer and find the directory C:\Windows\System32.
Locate the extracted .ocx file in C:\Windows\System32 and move it to C:\Windows\sysWOW64.
Click Start > Search > "cmd.exe", right-click the found item and click "Run as Administrator"
At the command prompt type "regsvr32 C:\Windows\sysWOW64\MSCOMCT2.ocx" and hit enter
Open Excel and fire up the VB Editor
Click Tools > References and choose "Microsoft Windows Common Controls 2-6.0 (sp6)
Select any userform in the VB project, click Tools > Additional Controls
Select "Microsoft MOnthview Control 6.0 (SP6)
Use 'DatePicker' control in the VBA user form.
From How to Add Date Picker To VBA UserForm
For few versions MSCOMCT2.cab isn't working
You can try out the following script
Option Explicit
Dim ThisDay As Date
Dim ThisYear, ThisMth As Date
Dim CreateCal As Boolean
Dim i As Integer
Private Sub D1_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D1.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D1.ControlTipText
End If
End Sub
Private Sub D10_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D10.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D10.ControlTipText
End If
End Sub
Private Sub D11_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D11.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D11.ControlTipText
End If
End Sub
Private Sub D12_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D12.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D12.ControlTipText
End If
End Sub
Private Sub D13_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D13.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D13.ControlTipText
End If
End Sub
Private Sub D14_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D14.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D14.ControlTipText
End If
End Sub
Private Sub D15_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D15.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D15.ControlTipText
End If
End Sub
Private Sub D16_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D16.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D16.ControlTipText
End If
End Sub
Private Sub D17_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D17.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D17.ControlTipText
End If
End Sub
Private Sub D18_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D18.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D18.ControlTipText
End If
End Sub
Private Sub D19_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D19.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D19.ControlTipText
End If
End Sub
Private Sub D2_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D2.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D2.ControlTipText
End If
End Sub
Private Sub D20_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D20.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D20.ControlTipText
End If
End Sub
Private Sub D21_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D21.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D21.ControlTipText
End If
End Sub
Private Sub D22_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D22.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D22.ControlTipText
End If
End Sub
Private Sub D23_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D23.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D23.ControlTipText
End If
End Sub
Private Sub D24_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D24.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D24.ControlTipText
End If
End Sub
Private Sub D25_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D25.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D25.ControlTipText
End If
End Sub
Private Sub D26_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D26.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D26.ControlTipText
End If
End Sub
Private Sub D27_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D27.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D27.ControlTipText
End If
End Sub
Private Sub D28_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D28.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D28.ControlTipText
End If
End Sub
Private Sub D29_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D29.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D29.ControlTipText
End If
End Sub
Private Sub D3_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D3.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D3.ControlTipText
End If
End Sub
Private Sub D30_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D30.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D30.ControlTipText
End If
End Sub
Private Sub D31_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D31.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D31.ControlTipText
End If
End Sub
Private Sub D32_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D32.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D32.ControlTipText
End If
End Sub
Private Sub D33_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D33.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D33.ControlTipText
End If
End Sub
Private Sub D34_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D34.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D34.ControlTipText
End If
End Sub
Private Sub D35_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D35.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D35.ControlTipText
End If
End Sub
Private Sub D36_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D36.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D36.ControlTipText
End If
End Sub
Private Sub D37_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D37.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D37.ControlTipText
End If
End Sub
Private Sub D38_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D38.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D38.ControlTipText
End If
End Sub
Private Sub D39_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D39.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D39.ControlTipText
End If
End Sub
Private Sub D4_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D4.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D4.ControlTipText
End If
End Sub
Private Sub D40_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D40.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D40.ControlTipText
End If
End Sub
Private Sub D41_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D41.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D41.ControlTipText
End If
End Sub
Private Sub D42_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D42.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D42.ControlTipText
End If
End Sub
Private Sub D5_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D5.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D5.ControlTipText
End If
End Sub
Private Sub D6_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D6.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D6.ControlTipText
End If
End Sub
Private Sub D7_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D7.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D7.ControlTipText
End If
End Sub
Private Sub D8_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D8.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D8.ControlTipText
End If
End Sub
Private Sub D9_Click()
If CBO_AddTime.Value = True Then
Selection.Value = Me.D9.ControlTipText & ":" & Time()
ElseIf CBO_AddTime.Value = False Then
Selection.Value = Me.D9.ControlTipText
End If
End Sub
Private Sub Frame1_Click()
End Sub
Private Sub UserForm_Initialize()
Application.EnableEvents = False
ThisDay = Date
ThisMth = Format(ThisDay, "MM")
ThisYear = Format(ThisDay, "YYYY")
For i = 1 To 12
CB_Month.AddItem Format(DateSerial(Year(Date), Month(Date) + i, 0), "mm")
Next
CB_Month.ListIndex = Format(Date, "mm") - Format(Date, "mm")
For i = -10 To 50
If i = 1 Then CB_Year.AddItem Format((ThisDay), "yyyy") Else CB_Year.AddItem _
Format((DateAdd("yyyy", (i - 1), ThisDay)), "yyyy")
Next
CB_Year.ListIndex = 11
CreateCal = True
Call Build_Calendar
Application.EnableEvents = True
LBLTime.Caption = Time()
LBLDate.Caption = Format(Date)
If CreateCal = True Then
UserForm1.Caption = CB_Month.Value & " " & CB_Year.Value
End If
End Sub
Private Sub Build_Calendar()
For i = 1 To 42
If i < Weekday((CB_Month.Value) & "/1/" & (CB_Year.Value)) Then
Controls("D" & (i)).Caption = Format(DateAdd("d", (i - Weekday((CB_Month.Value) & "/1/" & (CB_Year.Value))), _
((CB_Month.Value) & "/1/" & (CB_Year.Value))), "d")
Controls("D" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((CB_Month.Value) & "/1/" & (CB_Year.Value))), _
((CB_Month.Value) & "/1/" & (CB_Year.Value))), "d/mm/yyyy")
ElseIf i >= Weekday((CB_Month.Value) & "/1/" & (CB_Year.Value)) Then
Controls("D" & (i)).Caption = Format(DateAdd("d", (i - Weekday((CB_Month.Value) & "/1/" & (CB_Year.Value))), _
((CB_Month.Value) & "/1/" & (CB_Year.Value))), "d")
Controls("D" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((CB_Month.Value) & "/1/" & (CB_Year.Value))), _
((CB_Month.Value) & "/1/" & (CB_Year.Value))), "d/mm/yyyy")
End If
Next
End Sub
ByRef argument type mismatch when running the fileconv.xla add-in in Excel 97.
The reason I need this to work is because I need to convert ~100 Lotus 1-2-3 files from wk* to xls.
The term highlighted in VBA when I compile is marked by double asteriks in the separated code:
Workbooks.Open Filename:=PathFile(**p_FileInfo**(i, 3), p_FileInfo(i, 4)), ReadOnly:=True, Password:="password"
Sub FinishSub()
Dim TestOpen As Boolean
Dim DirDest As String
Application.ScreenUpdating = False
CreateDir "wzkfpbdxwzkfpbdxwzkfpbdx"
If Not (DirCreated) Then
Application.ScreenUpdating = True
Exit Sub
End If
If Len(dlg.DropDowns("DriveDD").List(dlg.DropDowns("DriveDD").ListIndex)) <> 2 Then
DirDest = Right(dlg.DropDowns("DriveDD").List(dlg.DropDowns("DriveDD").ListIndex), _
Len(dlg.DropDowns("DriveDD").List(dlg.DropDowns("DriveDD").ListIndex)) - 3) & _
Right(FullPath, Len(FullPath) - 2)
Else
DirDest = dlg.DropDowns("DriveDD").List(dlg.DropDowns("DriveDD").ListIndex) & _
Right(FullPath, Len(FullPath) - 2)
End If
Set wbResult = Workbooks.Add
ActiveCell.Value = LookupString("File")
Range("B1").Value = LookupString("ConvertedTo")
Range("C1").Value = LookupString("Result")
Range("D1").Value = LookupString("Reason")
Range("A2").Select
k = 0
For i = 1 To CountFile
p_FileInfo(i, 5) = DirDest
If p_FileInfo(i, 7) = "yes" Then
k = k + 1
On Error GoTo ErrorOpen
Success = "True"
ErrorMsg = ""
SetWaitCursor True
If TestIfWorkbookIsOpen(p_FileInfo(i, 4)) Then Workbooks(p_FileInfo(i, 4)).Close saveChanges:=False
Application.StatusBar = LookupString("Opening") & p_FileInfo(i, 4) & "(" & k & "/" & CountFileToConvert & ")"
Application.DisplayAlerts = False
Workbooks.Open Filename:=PathFile(**p_FileInfo**(i, 3), p_FileInfo(i, 4)), ReadOnly:=True, Password:="password"
On Error GoTo 0
On Error Resume Next
Application.StatusBar = LookupString("Saving") & p_FileInfo(i, 6) & "(" & k & "/" & CountFileToConvert & ")"
' Check if the XLS filename already exists.
FindFileName
Workbooks(p_FileInfo(i, 4)).SaveAs Filename:=PathFile(p_FileInfo(i, 5), p_FileInfo(i, 6)), FileFormat:=xlNormal
'Application.StatusBar = False
Workbooks(p_FileInfo(i, 4)).Close saveChanges:=False
Workbooks(p_FileInfo(i, 6)).Close saveChanges:=False
SaveIsSuccess Success
SetWaitCursor False
On Error GoTo 0
End If
Next i
SaveIsSuccess "End"
Application.StatusBar = False
Application.ScreenUpdating = True
Exit Sub
ErrorOpen: ' Error-handling routine.
Select Case Err ' Evaluate Error Number.
Case 18
TestMsgBox = MsgBox(LookupString("UserInterruption", "AlertTable"), vbYesNo)
If TestMsgBox = vbYes Then
On Error Resume Next
Application.StatusBar = False
Workbooks(p_FileInfo(i, 4)).Close saveChanges:=False
Workbooks(p_FileInfo(i, 6)).Close saveChanges:=False
Application.ScreenUpdating = True
Exit Sub
On Error GoTo 0
Else
Resume Next
End If
Case 1004
SetWaitCursor False
Set dlg = ThisWorkbook.DialogSheets("Password")
dlg.DialogFrame.Characters.Text = p_FileInfo(i, 4)
If TryAgain = False Then
dlg.TextBoxes("PassTB").Text = LookupString("IsProtected", "AlertTable")
dlg.EditBoxes("PassEB").Text = ""
Else
dlg.TextBoxes("PassTB").Text = LookupString("InvalidPassword", "AlertTable")
End If
ShowTest = dlg.Show
Select Case ShowTest
Case True
Resume
Case False
Success = "False"
ErrorMsg = Error()
Resume Next
End Select
SetWaitCursor True
End Select
Application.StatusBar = False
End Sub
I assume you have this
Public Function PathFile(ByRef a As String, ByRef b As String)
PathFile = "C:\Bla.txt"
End Function
and p_FileInfo is an Array, so in this case you have to call the function like this:
Workbooks.Open Filename:=PathFile(CStr(p_FileInfo(i, 3)), CStr(p_FileInfo(i, 4))), ReadOnly:=True, Password:="password"
That should work if I am not misunderstand your question.