Hi bcmk29,
I'm still unsure about what your data looks like so I had to do some guessing.
First of all you should avoid referencing sheets or worksheets by their indexnumber - if you do not protect the structure sheets may be moved resulting in either run-time errors or unwanted results. Referring to the tab sheetnames is more reliant in my eyes as the sheets could be moved anywhere but users may change these names (resulting in run-time errors). The safest way for me is to refer to the CodeName of the sheets: it can only be altered in the VBE or by code, and most people don't even know that CodeNames exist. And it worls without problems in ThisWorkbook, teh workbook with the code. By default CodeNames will not be accepted if you refer to a differetn workbook - there's a workaround to use them anyhow.
I worked with tab sheetnames in my codes.
I inserted 2 standard modules (I actually renamed them to modStartUF and modDataImport), code for modStartUF
VBA Code:
Public gwkbImport As Workbook
Public gwsNewHeader As Worksheet
'
Sub Call_UF()
UserForm1.Show
End Sub
Code for modDataImport:
VBA Code:
Sub DataImport()
Dim lngImport As Long
Const cblnClearGlobals As Boolean = False
'/// This loop can be omitted as the following code overwrites some/most/all of the data
For lngImport = 2 To ThisWorkbook.Worksheets("Sheet4").Cells(Rows.Count, 19).End(xlUp).Row
gwsNewHeader.Range(Sheets("Sheet3").Range("T" & lngImport).Value).Copy ThisWorkbook.Worksheets("Input").Cells(1, lngImport - 1)
Next lngImport
Application.ScreenUpdating = True
With ThisWorkbook
.Worksheets("Sheet3").Range("A1:U1").Copy
With .Worksheets("Input").Range("A1").Resize(1, 21)
.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
.PasteSpecial Paste:=xlPasteFormats, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
End With
End With
Application.CutCopyMode = False
gwkbImport.Close SaveChanges:=False
Application.ScreenUpdating = True
With ThisWorkbook.Worksheets("Sheet4")
.Range("P2", .Cells(.Rows.Count, "P").End(xlUp)).ClearContents
.Range("S2", .Cells(.Rows.Count, "S").End(xlUp)).ClearContents
.Range("R1").ClearContents
End With
Application.Goto ThisWorkbook.Worksheets("Input").Range("A1"), Scroll:=True
Set gwsNewHeader = Nothing
Set gwkbImport = Nothing
End Sub
Maybe due to an error in my understanding the imported cells from the loop are overwritten as headers are copied over to the area which just had been filled: You should check this and alter the code to do what you want it to do at the places needed.
The following routines all are located behind the UserForm:
VBA Code:
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 wbActive As Workbook 'workbook which is activated in Excel at start: ActiveWorkbook,
'workbook holding the code: ThisWorkbook
Dim wsSheet3 As Worksheet 'object for "Sheet3"
Dim wsInput As Worksheet 'object for "Input"
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
Const cstrProcName As String = "UserForm1_Initialize"
On Error GoTo err_here
blnUnload = False
Set wbActive = ThisWorkbook
Set wsSheet3 = wbActive.Sheets("Sheet3")
Set wsInput = wbActive.Sheets("Input")
If wsInput.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:=gwkbImport.FullName)
End If
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
If blnUnload = False Then
wsSheet3.Range("P2:P" & wsSheet3.Rows.Count).ClearContents
varArr = gwsNewHeader.Range("A1").Resize(1, gwsNewHeader.Cells(1, Columns.Count).End(xlToLeft).Column)
varArr = WorksheetFunction.Transpose(varArr)
wsSheet3.Range("P2").Resize(UBound(varArr), 1).Value = varArr
Application.Goto wsSheet3.Range("P1"), True
End If
end_here:
Set wsSheet3 = Nothing
Set wsInput = Nothing
Set wbActive = Nothing
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
Resume end_here
End Sub
VBA Code:
Private Sub UserForm_Activate()
Dim wsSheet3 As Worksheet 'object for Sheet3
Dim rng2List As Range 'object holding range for List for CBs
Dim objCtrl As Control 'object to cycle through the Controls on the UF
Set wsSheet3 = ThisWorkbook.Sheets("Sheet3")
Set rng2List = wsSheet3.Range("P2", wsSheet3.Cells(Rows.Count, 16).End(xlUp))
For Each objCtrl In Me.Controls
If TypeOf objCtrl Is MSForms.ComboBox Then
objCtrl.List = rng2List.Value
End If
Next objCtrl
Application.Goto Sheets("Input").Range("A1"), True
Set rng2List = Nothing
Set wsSheet3 = Nothing
End Sub
You must spend some work on the next procedure as my UserForm and Controls look different from yours, as well as that I renamed the buttons. If you run into trouble here and need help just call for it:
VBA Code:
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
Dim wsSheet3 As Worksheet
Static slngAddCtrls As Long 'number of controls added
Const cblnHaHoBe As Boolean = True '!!!!! change to False, uncomment and adjust your code to suit
'my UserForm has other dimensions than yours, I called my Buttons
'cmdAdd and CmdProc
Set wsSheet3 = ThisWorkbook.Sheets("Sheet3")
lngLR_P = wsSheet3.Cells(wsSheet3.Rows.Count, 16).End(xlUp).Row
lngLR_U = wsSheet3.Cells(wsSheet3.Rows.Count, 21).End(xlUp).Row
If cblnHaHoBe Then
'all dimensions are tailored for my sample
slngAddCtrls = slngAddCtrls + 1
'general height of UserForm
Me.Height = Me.Height + (30 * slngAddCtrls)
'start of last constant element, new ones should be listed below
lngUFHeight = 230
Set objNewLB = Me.Controls.Add("Forms.listbox.1", True)
With objNewLB
.Name = "Listbox" & slngAddCtrls
.Left = 30
.Height = 25
.Width = 108
.Top = lngUFHeight + (25 * slngAddCtrls)
.RowSource = wsSheet3.Name & "!U10:U" & lngLR_U
End With
Set objNewCB = Me.Controls.Add("Forms.combobox.1", True)
With objNewCB
.Name = "Combobox" & slngAddCtrls
.Left = 168
.Height = 25
.Width = 108
.Top = lngUFHeight + (25 * slngAddCtrls)
.RowSource = wsSheet3.Name & "!P2:P" & lngLR_P
End With
With cmdAdd
.Left = 30
.Top = lngUFHeight + 5 + (25 * (slngAddCtrls + 2))
End With
With cmdProc
.Left = 168
.Top = lngUFHeight + 5 + (25 * (slngAddCtrls + 2))
End With
With Label9
.Left = 30
.Top = lngUFHeight + (30 * (slngAddCtrls + 1))
If slngAddCtrls > 0 Then
.Caption = slngAddCtrls & " Fields Added"
End If
End With
Else
' slngAddCtrls = slngAddCtrls + 1
' lngUFHeight = 202
' Set objNewLB = Me.Controls.Add("Forms.listbox.1", True)
' slngAddCtrls = slngAddCtrls + 1
' With objNewLB
' .Name = "Listbox" & slngAddCtrls
' .Left = 17
' .lngUFHeight = 20
' .Width = 92
' .Top = lngUFHeight + (25 * slngAddCtrls)
' .RowSource = "Sheet3!U10:U" & lngLR_U
' End With
' Set objNewCB = Me.Controls.Add("Forms.combobox.1", True)
' lngUFHeight = 200
' With objNewCB
' .Name = "Combobox" & slngAddCtrls
' .Left = 114
' .Width = 107
' .Top = lngUFHeight + (25 * slngAddCtrls)
' .RowSource = "Sheet3!P2:P" & lngLR_P
' End With
' lngUFHeight = 225
' With CommandButton1
' .Left = 30
' .Top = lngUFHeight + (25 * slngAddCtrls)
' End With
' lngUFHeight = 225
' With CommandButton2
' .Left = 126
' .Top = lngUFHeight + (25 * slngAddCtrls)
' End With
' lngUFHeight = 305
' DataMap.lngUFHeight = lngUFHeight + (25 * slngAddCtrls)
' lngUFHeight = 260
' With Label9
' .Caption = slngAddCtrls & " Field Added"
' .Left = 86
' .Top = lngUFHeight + (25 * slngAddCtrls)
' If slngAddCtrls > 1 Then
' .Caption = slngAddCtrls & " Fields Added"
' End If
' End With
' Me.Tag = slngAddCtrls
End If
Set wsSheet3 = Nothing
End Sub
VBA Code:
Private Sub cmdProc_Click()
Dim lngCounter As Long
Dim blnComplete As Boolean
Dim objCtrl As Control
Dim objColNoDupes As New Collection
For Each objCtrl In Me.Controls
If TypeOf objCtrl Is MSForms.ComboBox Then
With objCtrl
Debug.Print objCtrl.Name
blnComplete = Len(.Value) > 0
If blnComplete Then
On Error Resume Next
objColNoDupes.Add .Value, CStr(.Value)
If Err.Number = 457 Then
MsgBox "Item '" & .Value & "' has already been chosen, please alter and try again.", vbInformation, "Double encountered"
.SetFocus
Exit Sub
End If
Else
MsgBox "Please fill blank field", 48, "Entry Required"
.SetFocus
Exit Sub
End If
End With
End If
Next objCtrl
If blnComplete Then
With ThisWorkbook.Worksheets("Sheet3")
.Range("S2", .Range("S" & .Rows.Count).End(xlUp)).ClearContents
For lngCounter = 1 To objColNoDupes.Count
.Range("S" & lngCounter + 1).Value = objColNoDupes(lngCounter)
Next lngCounter
End With
Unload Me
Call DataImport
End If
End Sub
If you have questions on the code feel free to ask - on the sample I built code ran like I expected it to do (still I don't know if I put in the correct guesses in my setup). And I placed a formular button on sheet Input and assigned macro Call_UF to it.
Lots of code. If you want you may download my sample workbook
here. A word on the properties: the workbook is based on a template I created or modified at the date that is shown as Date pf creation.
Ciao,
Holger
