Dim mstrFullNameWB As String
Dim mstrNameWB As String
Dim mstrNameWS As String
'
Private Sub UserForm_Initialize()
Dim lngIndexWS As Long 'index of worksheet in new workbook if more than one worksheet
Dim lngWS As Long 'counter for index of worksheets in opened workbook
Dim varFile As Variant 'variable to hold path and filename for workbook to open
Dim varArr() As Variant 'values for the header values to be copied
Dim strWS As String 'Holding the names of worksheets of new workbook
Dim ws As Worksheet 'for looping worksheets in new workbook
Dim wb As Workbook 'for looping through all open workbooks
Dim blnRunOnce As Boolean 'boolean for getting information about worksheets,
Dim blnUnload As Boolean 'boolean whether to unload the UF
Dim lngColMax As Long
Dim lngCounter As Long
Dim lngArr As Long
Dim strAddress As String
Const cstrProcName As String = "UserForm1_Initialize"
Const cblnBcmk As Boolean = False
On Error GoTo err_here
blnUnload = False
gblnCleanUp = True
If tblInput.Cells(Rows.Count, 1).End(xlUp).Row <> 1 Then GoTo end_here
If gwkbImport Is Nothing Then
varFile = Application.GetOpenFilename("(*.xlsx),", MultiSelect:=False)
If varFile = False Then
MsgBox "No file selected to import.", 48
blnUnload = True
GoTo end_here
End If
Set gwkbImport = Workbooks.Open(Filename:=varFile)
Else
For Each wb In Workbooks
If wb.Name = gwkbImport.Name Then Exit For
Next wb
Set gwkbImport = Workbooks.Open(Filename:=varFile)
End If
mstrFullNameWB = gwkbImport.FullName
mstrNameWB = gwkbImport.Name
If cblnBcmk Then MsgBox gwkbImport.FullName
If gwsNewheader Is Nothing Then
If gwkbImport.Worksheets.Count > 1 Then
blnRunOnce = False
reIB:
If blnRunOnce = False Then
For Each ws In gwkbImport.Worksheets
lngWS = lngWS + 1
strWS = strWS & lngWS & " : " & ws.Name & vbCrLf
Next ws
blnRunOnce = True
End If
lngIndexWS = Application.InputBox("Enter worksheet number" & vbCrLf & Left(strWS, Len(strWS) - 1), "Worksheet selection", , , , , , 1)
If lngIndexWS > gwkbImport.Worksheets.Count Then
MsgBox "Invalid Worksheet Input, Try Again.", 48, "Entry Required"
GoTo reIB
ElseIf lngIndexWS = 0 Then
MsgBox "Procedure cancelled", vbInformation, "Stopping here"
gwkbImport.Close False
Set gwkbImport = Nothing
blnUnload = True
GoTo end_here
Else
Set gwsNewheader = gwkbImport.Worksheets(lngIndexWS)
End If
Else
Set gwsNewheader = gwkbImport.Worksheets(1)
End If
End If
mstrNameWS = gwsNewheader.Name
Err.Clear
On Error GoTo 0
If blnUnload = False Then
tblAdmin.Range("P2:P" & tblAdmin.Rows.Count).ClearContents
With gwsNewheader
lngColMax = .Cells(1, Columns.Count).End(xlToLeft).Column
lngArr = lngColMax - WorksheetFunction.CountBlank(.Range(.Cells(2, 1), .Cells(2, lngColMax)))
ReDim varArr(1 To lngArr, 1 To 2)
lngArr = 0
For lngCounter = 1 To lngColMax
If WorksheetFunction.CountBlank(.Range(.Cells(2, lngCounter), .Cells(4, lngCounter))) = 0 Then
lngArr = lngArr + 1
With .Cells(1, lngCounter)
varArr(lngArr, 1) = .Value
strAddress = Left(.Address(0, 0), Len(.Address(0, 0)) - 1)
varArr(lngArr, 2) = strAddress '& ":" & strAddress
End With
End If
Next lngCounter
End With
tblAdmin.Range("P2").Resize(UBound(varArr, 1), 2).Value = varArr
Erase varArr
Application.Goto tblAdmin.Range("P1"), True
End If
end_here:
Err.Clear
On Error GoTo 0
If blnUnload Then End
Exit Sub
err_here:
Debug.Print "Actual procedure name: " & cstrProcName & vbCrLf & _
"Error number: " & Err.Number & vbCrLf & _
"Error description: " & Err.Description
Err.Clear
On Error GoTo 0
Resume end_here
End Sub
Private Sub UserForm_Activate()
Dim rng2List As Range 'object holding range for List for CBs
Dim objCtrl As Control 'object to cycle through the Controls on the UF
Const cstrProcName As String = "UserForm1_Activate"
On Error GoTo err_here
glngAddCtrls = 0
Set rng2List = tblAdmin.Range("P2", tblAdmin.Cells(Rows.Count, 16).End(xlUp))
For Each objCtrl In Me.Controls
If TypeOf objCtrl Is MSForms.ComboBox Then
objCtrl.List = rng2List.Value
objCtrl.Style = 2
End If
Next objCtrl
Application.Goto tblInput.Range("A1"), True
end_here:
Set rng2List = Nothing
On Error GoTo 0
Exit Sub
err_here:
Debug.Print "Actual procedure name: " & cstrProcName & vbCrLf & _
"Error number: " & Err.Number & vbCrLf & _
"Error description: " & Err.Description
Err.Clear
On Error GoTo 0
Resume end_here
End Sub
Private Sub cmdAdd_Click()
Dim objNewLB As Object
Dim objNewCB As Object
Dim lngUFHeight As Long
Dim lngLR_P As Long
Dim lngLR_U As Long
Const cstrProcName As String = "cmdAdd_Click"
On Error GoTo err_here
lngLR_P = tblAdmin.Cells(tblAdmin.Rows.Count, 16).End(xlUp).Row
lngLR_U = tblAdmin.Cells(tblAdmin.Rows.Count, 21).End(xlUp).Row
If lngLR_P >= 9 + glngAddCtrls Then
glngAddCtrls = glngAddCtrls + 1
Me.Height = Me.Height + (30 * glngAddCtrls)
lngUFHeight = 230
Set objNewLB = Me.Controls.Add("Forms.label.1", True)
With objNewLB
.Name = "Label" & glngAddCtrls + 9
.Left = 30
.Height = 22
.Width = 108
.Top = lngUFHeight + (25 * glngAddCtrls)
.Caption = tblAdmin.Range("U" & glngAddCtrls + 9).Value
End With
Set objNewCB = Me.Controls.Add("Forms.combobox.1", True)
With objNewCB
.Name = "Combobox" & glngAddCtrls
.Left = 168
.Height = 22
.Width = 108
.Style = 2
.Top = lngUFHeight + (25 * glngAddCtrls)
.RowSource = tblAdmin.Name & "!P2:P" & lngLR_P
End With
With cmdAdd
.Left = 30
.Top = lngUFHeight + 5 + (25 * (glngAddCtrls + 2))
End With
With cmdProc
.Left = 168
.Top = lngUFHeight + 5 + (25 * (glngAddCtrls + 2))
End With
With Label9
.Left = 30
.Top = lngUFHeight + (30 * (glngAddCtrls + 1))
If glngAddCtrls > 0 Then
.Caption = glngAddCtrls & " Fields Added"
End If
End With
Else
MsgBox "Please check the data in '" & gwkbImport.FullName & vbCrLf & _
"as the number of Headers to import does not equal at least '" & _
8 + glngAddCtrls, vbInformation, "Not enough data"
Unload Me
End If
end_here:
On Error GoTo 0
Exit Sub
err_here:
Debug.Print "Actual procedure name: " & cstrProcName & vbCrLf & _
"Error number: " & Err.Number & vbCrLf & _
"Error description: " & Err.Description
Err.Clear
On Error GoTo 0
Resume end_here
End Sub
Private Sub cmdProc_Click()
Dim blnComplete As Boolean
Dim blnWBCheck As Boolean
Dim objCtrl As Control
Dim lngCounter As Long
Dim lngUnique As Long
Dim lngAll As Long
Dim lngDouble As Long
Dim varUnique() As Variant
Dim varAll() As Variant
Dim wb As Workbook
Const clngMaxDoubles As Long = 2
Const cstrProcName As String = "cmdProc_Click"
On Error GoTo err_here
ReDim varUnique(1 To 1)
ReDim varAll(1 To 1)
If tblAdmin.Cells(tblAdmin.Rows.Count, 16).End(xlUp).Row >= 9 + glngAddCtrls Then
For Each objCtrl In Me.Controls
If TypeOf objCtrl Is MSForms.ComboBox Then
With objCtrl
blnComplete = Len(.Value) > 0
If blnComplete Then
lngAll = lngAll + 1
ReDim Preserve varAll(1 To lngAll)
varAll(lngAll) = .Value
If IsError(Application.Match(.Value, varUnique, 0)) Then
lngUnique = lngUnique + 1
ReDim Preserve varUnique(1 To lngUnique)
varUnique(lngUnique) = .Value
Else
lngDouble = lngDouble + 1
If lngDouble = clngMaxDoubles Then
Select Case MsgBox("Max of items to duplicate reached." & vbCrLf & _
"Ignore - Continue" & vbCrLf & _
"Retry - Change Item" & vbCrLf & _
"Abort - End Process", vbAbortRetryIgnore, "What to do?")
Case vbIgnore
Exit For
Case vbRetry
.SetFocus
GoTo end_here
Case vbAbort
GoTo end_here
End Select
End If
End If
Else
MsgBox "Please fill blank field", 48, "Entry Required"
.SetFocus
GoTo end_here
End If
End With
End If
Err.Clear
On Error GoTo 0
Next objCtrl
If blnComplete Then
Err.Clear
On Error GoTo 0
With tblAdmin
.Range("S2", .Range("S" & .Rows.Count).End(xlUp)).ClearContents
.Range("S2").Resize(UBound(varAll), 1).Value = WorksheetFunction.Transpose(varAll)
End With
For Each wb In Workbooks
If wb.Name = mstrNameWB Then
blnWBCheck = True
Exit For
End If
Next wb
If blnWBCheck = False Then
Set gwkbImport = Workbooks.Open(mstrFullNameWB)
Set gwsNewheader = gwkbImport.Sheets(mstrNameWS)
End If
gblnCleanUp = False
Unload Me
Call DataImport
End If
Else
MsgBox "Please check the data in '" & mstrFullNameWB & vbCrLf & _
"as the number of Headers to import does not equal at least '" & _
8 + glngAddCtrls, vbInformation, "Not enough data"
Unload Me
End If
end_here:
Erase varUnique
Erase varAll
Err.Clear
On Error GoTo 0
Exit Sub
err_here:
Debug.Print "Actual procedure name: " & cstrProcName & vbCrLf & _
"Error number: " & Err.Number & vbCrLf & _
"Error description: " & Err.Description
Err.Clear
On Error GoTo 0
Resume end_here
End Sub
Private Sub UserForm_Terminate()
Call CleanUp
End Sub
