Drag and drop multiple files to Userform - excel

I am trying to drag and drop more than one file on a Userform to get their paths. I managed it with one file thanks to this.
When I change FilePath = Data.files(1) to FilePath = Data.Files(2) or (i), I get a message "Table Expected". Should I create a Table and Redim it?
My work so far:
This one does the job (opening the file and copying it into a selected sheet)
Dim Wb, FilePath As String
Dim WbIni, WbCib As Workbook
Private Sub CommandButton2_Click()
If FilePath = vbNullString Then
MsgBox "Aucun fichier n'a été importé", vbCritical, "Anomalie"
Unload UserForm1
Exit Sub
End If
Set WbCib = Workbooks.Open(Filename:=FilePath)
MsgBox WbCib.Name
i = WbCib.ActiveSheet.Range("A1").End(xlDown).Row
WbCib.ActiveSheet.Range("A1:A" & i).Copy
ActiveSheet.Paste Destination:=WbIni.Worksheets("Target").Range("A1:A" & i)
WbIni.Sheets("Target").Activate
WbCib.Close
Unload UserForm1
End Sub
This one initializes my TreeView for the drag and drop
Private Sub UserForm_Initialize()
Wb = ThisWorkbook.Name
Set WbIni = ActiveWorkbook
TreeView1.OLEDropMode = ccOLEDropManual
End Sub
This one gives me the file path. I think I need to loop it.
Private Sub TreeView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
FilePath = Data.Files(1)
Workbooks(Wb).Activate
MsgBox FilePath
End Sub

Thanks to #R.Roe's comment, I managed to do what I wanted :
Dim x, y As Integer
Dim PathTable As String
Dim FilePath As Variant
Private Sub TreeView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
Dim i As Integer
Workbooks(Wb).Activate
'Counting file paths I dropped
For Each FilePath In Data.Files()
i = i + 1
Next FilePath
'Redim my table
ReDim PathTable(i)
i = 1
'Adding data to my table
For x = 0 To UBound(PathTable) - 1
PathTable(x) = Data.Files(i)
i = i + 1
Next x
'Just to make sure it works
For x = 0 To UBound(PathTable) - 1
MsgBox PathTable(x)
Next x
End Sub
Cheers!

Related

Excel Drag/Drop to Get Filename and Path

I have a user form "UserForm1" and am using the following code to obtain the filename and path of a file that the user has dragged and dropped into the TreeView located on the userform.
Public Sub TreeView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
StrPath = Data.Files(1)
Debug.Print StrPath
Call PrintPath
End Sub
Then in the UserForm_Initialize I have
TreeView1.OLEDropMode = ccOLEDropManual
I know this code is getting the path and name because I'm able to debug.print it. However, my issue is I can't get this filename and path to be utilized in a module. For instance I have tried to do the following for the simplest of uses (to print the filename and path to cell A1):
Public Sub PrintPath()
UserForm1.TreeView1.StrPath = Range("A1").Value
'StrPath.Value = Range("A1").Value
'UserForm1.StrPath.Value = Range("A1").Value
'Range("A1").Value = UserForm1.Data.Files(1)
End Sub
All of the commented lines are other versions I have attempted with no avail.
I typically get Object does not exist. Sometimes 424 errors.
Can anyone point me in the right direction?
Please and thank you!
Chris
The typical way to do this woould be to pass the path as an argument to PrintPath
Public Sub TreeView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, _
Button As Integer, Shift As Integer, x As Single, y As Single)
Dim strPath
strPath = Data.Files(1)
Debug.Print strPath
PrintPath strPath '<< pass in the path
End Sub
Public Sub PrintPath(sPath)
ActiveSheet.Range("A1").Value = sPath
End Sub
I have just now figured out the answer. In the UserForm1 Code I did
Option Explicit
Public StrPath As Variant
Then in the module I was able to use it with
UserForm1.StrPath
i.e.
Range("A1").Value = UserForm1.StrPath

How to add autofill to all the textboxes

I am new to vba and I want to learn. Please help me with the following:
I have this application(see the picture) which I use to enter data in a worksheet (it is more easy to use compared to completing manually). It is basically an inventory management system. When I add a product in there I can choose between sale or purchase.
The next thing I would like to implement is to autofill the form whenever I want to add a sale (considering it was added as a purchase in the first place), based on a serial code for example. This would be very useful because I wont have to complete all the text boxes again when I enter a sale in the database
Do you have any ideas about how I could do this?
Kind regard,
Traian.
So, basically I shouldn't help since you have not done your research, but I did find it interesting to see if I could create such a function.
You wont be able to simply paste the code but it does work exactly as a autofill.
This is the "data" source I used for the autofill, it's looking for the left value and will autocomplete that textbox, as well as a secondary textbox with the value from column C. This would work with n numbers of autofills.
I only used 2 different fields to test this idea, disregard the labels. This is how it looked without typing anything.
As soon as you start to type, the "autofill" appears.
If you were to "hover" over the autofill, it will turn a different color, as well as all the input sheets, the input sheet also now includes the autofilled answers. if you were to "unhover"(hover over anything except the autofill) it will revert back to the second picture.
If I were to write this code again for a real project, I would change a couple of thing.
There might be leftover code from my testing, I would remove this.
I would use global variables so to avoid declaring variables more than one time.
I would name the textboxes and label in a better way.
I would complicate the textboxes with labels as to get the text to align in center.
The order of the code might not be the best for you to understand.
etc.
Here is the code:
Private Sub Autofill_Click()
Dim BestOption As Integer
Dim ValueRange As Range
Set ValueRange = Sheets("sheet1").Range("B8:B13")
Dim Start As Range
Set Start = Sheets("sheet1").Range("B7")
BestOption = WorksheetFunction.Match(Autofill, ValueRange, 0)
TextBox2 = Start.Offset(BestOption, 1)
TextBox1 = Start.Offset(BestOption, 0)
Autofill.Visible = False
TextBox3.Visible = False
TextBox4.Visible = False
End Sub
Private Sub TextBox1_Change()
Dim Start As Range
Dim ValueRange As Range
Dim MatchCounter As Integer
Set Start = Sheets("sheet1").Range("B7")
Set ValueRange = Sheets("sheet1").Range("B8:B13")
If TextBox1 = "" Then
Autofill.Visible = False
Else
'Call FindClosestMatch(TextBox1)
Autofill.Visible = True
Autofill = Start.Offset(FindClosestMatch(TextBox1) + 1, 0)
End If
End Sub
Function FindClosestMatch(Entry As String) As Integer
Dim BestOption As Integer
Dim Start As Range
Set Start = Sheets("sheet1").Range("B7")
Dim MyArray(6) As String
Dim i As Integer
Dim j As Integer
Dim iChar As String
Dim EntryChar As String
For i = 0 To 5
MyArray(i) = Start.Offset(i + 1, 0)
Next i
For j = 1 To Len(Entry)
EntryChar = Mid(Entry, j, 1)
For i = 0 To 5
If EntryChar = "" Then
Exit For
End If
iChar = Mid(MyArray(i), j, 1)
If iChar = EntryChar Then
BestOption = i
Else
MyArray(i) = "................."
End If
Next i
Next j
FindClosestMatch = BestOption
End Function
'hover
Private Sub Autofill_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Autofill.BackColor = &H80000002
TextBox3.BackColor = &H80000002
TextBox4.BackColor = &H80000002
Dim BestOption As Integer
Dim ValueRange As Range
Set ValueRange = Sheets("sheet1").Range("B8:B13")
Dim Start As Range
Set Start = Sheets("sheet1").Range("B7")
BestOption = WorksheetFunction.Match(Autofill, ValueRange, 0)
TextBox3.Visible = True
TextBox4.Visible = True
TextBox4 = Start.Offset(BestOption, 1)
TextBox3 = Start.Offset(BestOption, 0)
End Sub
Private Sub TextBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call test
End Sub
Private Sub TextBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call test
End Sub
Private Sub TextBox3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call test
End Sub
Private Sub TextBox4_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call test
End Sub
Private Sub UserForm_Click()
Call test
Autofill.Visible = False
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call test
End Sub
Sub test()
Autofill.BackColor = &H80000000
TextBox1.BackColor = &H80000005
TextBox2.BackColor = &H80000005
TextBox3.Visible = False
TextBox4.Visible = False
End Sub
Problem to think about:
The autofill always give the best answer, even if no good answer exist. In those cases, the best answer is the first answer in the data structure.
It is case sensitive.
One charachter wrong and you wont find your answer.
Notes:
I used 4 textboxes, number 1 and 2 are sitting on top of each other, and number 2 and 4 are on top of each other. This was done to not lose the already typed input if you accidently hovered over the autofill.

Use VBA to assign all checkboxes to class module

I'm having a problem assigning VBA generated ActiveX checkboxes to a class module. When a user clicks a button, the goal of what I am trying to achieve is: 1st - delete all the checkboxes on the excel sheet; 2nd - auto generate a bunch of checkboxes; 3rd - assign a class module to these new checkboxes so when the user subsequently clicks one of them, the class module runs.
I've borrowed heavily from previous posts Make vba code work for all boxes
The problem I've having is that the 3rd routine (to assign a class module to the new checkboxes) doesn't work when run subsequently to the first 2 routines. It runs fine if run standalone after the checkboxes have been created. From the best I can tell, it appears VBA isn't "releasing" the checkboxes after they have been created to allow the class module to be assigned.
The below code is the simplified code that demonstrates this problem. In this code, I use a button on "Sheet1" to run Sub RunMyCheckBoxes(). When button 1 is clicked, the class module did not get assigned to the newly generated checkboxes. I use button 2 on "Sheet1" to run Sub RunAfter(). If button 2 is clicked after button 1 has been clicked, the checkboxes will be assigned to the class module. I can't figure out why the class module won't be assigned if just the first button is clicked. Help please.
Module1:
Public mcolEvents As Collection
Sub RunMyCheckboxes()
Dim i As Double
Call DeleteAllCheckboxesOnSheet("Sheet1")
For i = 1 To 10
Call InsertCheckBoxes("Sheet1", i, 1, "CB" & i & "1")
Call InsertCheckBoxes("Sheet1", i, 2, "CB" & i & "2")
Next
Call SetCBAction("Sheet1")
End Sub
Sub DeleteAllCheckboxesOnSheet(SheetName As String)
Dim obj As OLEObject
For Each obj In Sheets(SheetName).OLEObjects
If TypeOf obj.Object Is MSForms.CheckBox Then
obj.Delete
End If
Next
End Sub
Sub InsertCheckBoxes(SheetName As String, CellRow As Double, CellColumn As Double, CBName As String)
Dim CellLeft As Double
Dim CellWidth As Double
Dim CellTop As Double
Dim CellHeight As Double
Dim CellHCenter As Double
Dim CellVCenter As Double
CellLeft = Sheets(SheetName).Cells(CellRow, CellColumn).Left
CellWidth = Sheets(SheetName).Cells(CellRow, CellColumn).Width
CellTop = Sheets(SheetName).Cells(CellRow, CellColumn).Top
CellHeight = Sheets(SheetName).Cells(CellRow, CellColumn).Height
CellHCenter = CellLeft + CellWidth / 2
CellVCenter = CellTop + CellHeight / 2
With Sheets(SheetName).OLEObjects.Add(classtype:="Forms.CheckBox.1", Link:=False, DisplayAsIcon:=False, Left:=CellHCenter - 8, Top:=CellVCenter - 8, Width:=16, Height:=16)
.Name = CBName
.Object.Caption = ""
.Object.BackStyle = 0
.ShapeRange.Fill.Transparency = 1#
End With
End Sub
Sub SetCBAction(SheetName)
Dim cCBEvents As clsActiveXEvents
Dim o As OLEObject
Set mcolEvents = New Collection
For Each o In Sheets(SheetName).OLEObjects
If TypeName(o.Object) = "CheckBox" Then
Set cCBEvents = New clsActiveXEvents
Set cCBEvents.mCheckBoxes = o.Object
mcolEvents.Add cCBEvents
End If
Next
End Sub
Sub RunAfter()
Call SetCBAction("Sheet1")
End Sub
Class Module (clsActiveXEvents):
Option Explicit
Public WithEvents mCheckBoxes As MSForms.CheckBox
Private Sub mCheckBoxes_click()
MsgBox "test"
End Sub
UPDATE:
On further research, there is a solution posted in the bottom answer here:
Creating events for checkbox at runtime Excel VBA
Apparently you need to force Excel VBA to run on time now:
Application.OnTime Now ""
Edited lines of code that works to resolve this issue:
Sub RunMyCheckboxes()
Dim i As Double
Call DeleteAllCheckboxesOnSheet("Sheet1")
For i = 1 To 10
Call InsertCheckBoxes("Sheet1", i, 1, "CB" & i & "1")
Call InsertCheckBoxes("Sheet1", i, 2, "CB" & i & "2")
Next
Application.OnTime Now, "SetCBAction" '''This is the line that changed
End Sub
And, with this new formatting:
Sub SetCBAction() ''''no longer passing sheet name with new format
Dim cCBEvents As clsActiveXEvents
Dim o As OLEObject
Set mcolEvents = New Collection
For Each o In Sheets("Sheet1").OLEObjects '''''No longer passing sheet name with new format
If TypeName(o.Object) = "CheckBox" Then
Set cCBEvents = New clsActiveXEvents
Set cCBEvents.mCheckBoxes = o.Object
mcolEvents.Add cCBEvents
End If
Next
End Sub
If OLE objects suit your needs then I'm glad you've found a solution.
Are you aware, though, that Excel's Checkbox object could make this task considerably simpler ... and faster? Its simplicity lies in the fact that you can easily iterate the Checkboxes collection and that you can access its .OnAction property. It is also easy to identify the 'sender' by exploiting the Evaluate function. It has some formatting functions if you need to tailor its appearance.
If you're after something quick and easy then the sample below will give you an idea of how your entire task could be codified:
Public Sub RunMe()
Const BOX_SIZE As Integer = 16
Dim ws As Worksheet
Dim cell As Range
Dim cbox As CheckBox
Dim i As Integer, j As Integer
Dim boxLeft As Double, boxTop As Double
Set ws = ThisWorkbook.Worksheets("Sheet1")
'Delete checkboxes
For Each cbox In ws.CheckBoxes
cbox.Delete
Next
'Add checkboxes
For i = 1 To 10
For j = 1 To 2
Set cell = ws.Cells(i, j)
With cell
boxLeft = .Width / 2 - BOX_SIZE / 2 + .Left
boxTop = .Height / 2 - BOX_SIZE / 2 + .Top
End With
Set cbox = ws.CheckBoxes.Add(boxLeft, boxTop, BOX_SIZE, BOX_SIZE)
With cbox
.Name = "CB" & i & j
.Caption = ""
.OnAction = "CheckBox_Clicked"
End With
Next
Next
End Sub
Sub CheckBox_Clicked()
Dim sender As CheckBox
Set sender = Evaluate(Application.Caller)
MsgBox sender.Name & " now " & IIf(sender.Value = 1, "Checked", "Unchecked")
End Sub

VBA module call in userform to diff sheets

new and would like to ask if someone could possibly check my code to see where i'm making a mistake.
first, i've created a form with two textboxes and two buttons that will go and get two different directories and the associated files. this is done through a call to a function that loads the dir to the textboxes.
a button to call a function to navigate dir and get the file
Private Sub CommandButton3_Click()
'call selectFile function to select file
selectFile
End Sub
function to get workbooks into textboxes 1 and 2:
Public Function selectFile()
Dim fileNamePath1 As String
Dim fileNamePath2 As String
Dim workbookFilePath1 As String
Dim workbookFilePath2 As String
On Error GoTo exit_
If workbookFilePath1 = Empty And workbookFilePath2 = Empty Then
fileNamePath1 = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls", Title:="Open Workbook 1", MultiSelect:=False)
workbookFilePath1 = Dir(fileNamePath1)
'TextBox1.Text = workbookFilePath1
TextBox1.Value = fileNamePath1
fileNamePath2 = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls", Title:="Open Workbook 2", MultiSelect:=False)
workbookFilePath2 = Dir(fileNamePath2)
TextBox2.Value = fileNamePath2
If fileNamePath1 = False Or fileNamePath2 = False Then
MsgBox ("File selection was canceled.")
Exit Function
End If
End If
exit_:
End Function
up to here, the code is ok... can do better, but
here's where problems occur... i'd like to pass the directories as objects into the module to diff
button that executes module to diff:
Private Sub CommandButton1_Click()
getTheWorkbooksToCompare(fileNamePath1, fileNamePath2)
End Sub
i know that i've changed myPath1 and myPath2 to Workbooks, where I've had them as strings before
diffing module
Public Sub gettheWorkbooksToCompare(myPath1 As Workbook, myPath2 As Workbook)
Dim myExcelObj
Dim WorkbookObj1
Dim WorkbookObj2
Dim WorksheetObj1
Dim WorksheetObj2
Dim file1 As String
Dim file2 As String
Dim myWorksheetCounter As Integer
Dim i As Worksheet
Set myExcelObj = CreateObject("Excel.Application")
myExcelObj.Visible = True
Set file1 = Dir(myPath1)
Set file2 = Dir(myPath2)
Set WorkbookObj1 = myExcelObj.Workbooks.Open(file1)
Set WorkbookObj2 = myExcelObj.Workbooks.Open(file2)
Set NewWorkbook = myExcelObj.Workbooks.Add
While WorkbookObj1 <> Null And WorkbookObj2 <> Null
'While WorkbookObj1.ActiveWorkbook.Worksheets.count = WorkbookOjb2.ActiveWorkbook.Worksheets.count
myWorksheetCounter = ActiveWorkbook.Worksheets.count
myWorksheetCount = ActiveWorkbook.Worksheets.count
If WorksheetObj1.Worksheets.myWorksheetCounter = WorkbookObj2.Worksheets.myWorksheetCounter Then
Set WorksheetObj1 = WorkbookObj1.Worksheets(myWorksheetCounter)
Set WorksheetObj2 = WorkbookObj2.Worksheets(myWorksheetCounter)
Set myNewWorksheetObj = NewWorkbook.Worksheets(myWorksheetCounter)
For myWorksheetCounter = i To WorksheetObj1
For myWorksheetCount = j To WorksheetOjb2
'If cell.Value myWorksheetObj2.Range(cell.Address).Value Then
If cell.Value = myWorksheetObj2.Range(cell.address).Value Then
myNewWorksheetObj.Range(cell.address).Value = cell.address.Value
myNewWorksheetObj.Range(cell.address).Interior.ColorIndex = 3
Else
cell.Interior.ColorIndex = 0
End If
Next
'if doesn't work... use SaveChanges = True
myNewWorksheetObj.Workbooks.Save() = True
Next
Else
MsgBox ("The worksheets are not the same worksheets." & vbNewLine & "Please try again.")
End If
Wend
Set myExcelObj = Nothing
End Sub
So my question is... can someone please assist in seeing where i'm going wrong? essentially, i'm having some issues in trying to get this working.
much appreciated
i've gone through and cleaned up some areas a little bit... but now have a: "run time error '438': object doesn't support this propety or method" at the while loop code that i've updated the post with
I see a typo on CommandButton1_Click
Private Sub CommandButton1_Click()
getTheWorkbooksToCompare(fileNamePath1, fileNamePath2)
End Sub
Public Sub gettheWorkbooksToCompare(myPath1 As Workbook, myPath2 As Workbook)
There might be something more, but your not capitalizing the "T" in getThe, but you call it that way.

Custom right-click menu - OnAction works straight away rather than on button-press

I'm creating a custom menu in Excel which consists of various sub-menus. It's for picking various machinery items and there's about 250 possible outcomes.
In any case, I've got the menu built and want it so that the .Caption is entered into the cell when the menu is used. I've put the .OnAction into the relevant buttons but, unfortunately, the .OnAction activates when the file is opened, not when the button is clicked. As such, all 250-odd .Captions are quickly entered into the same cell in quick succession.
Quick edit - the important bit is towards the bottom of the BuildMenus, where the .OnAction calls the function AddStuff. I know this is running on the Workbook_Activate which is why it runs straight away but everywhere else I've looked online does it the same way.
Private Sub Workbook_Activate()
BuildMenus
End Sub
Private Sub BuildMenus()
'Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim AmountOfCats As Integer
Dim ThisIsMyCell As String
ThisIsMyCell = ActiveCell.Address
'this is where we would set the amount of categories. At the moment we'll have it as 15
AmountOfCats = 15
Dim cBut As CommandBarControl
Dim Cats As CommandBarControl
Dim SubCats As CommandBarControl
Dim MenuDesc As CommandBarButton
On Error Resume Next
With Application
.CommandBars("Cell").Controls("Pick Machinery/Plant...").Delete
End With
Set cBut = Application.CommandBars("Cell").Controls.Add(Type:=msoControlPopup, Temporary:=True)
cBut.Caption = "Pick Machinery/Plant.."
With cBut
.Caption = "Pick Machinery/Plant..."
.Style = msoButtonCaption
End With
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim SC As Integer
Dim AmountOfMenus As Integer
SC = 1
Dim MD As Integer
MD = 1
Dim MyCaption As String
For i = 0 To AmountOfCats - 1
Set Cats = cBut.Controls.Add(Type:=msoControlPopup, Temporary:=True)
Cats.Caption = Categories(i + 1)
Cats.Tag = i + 1
For j = 0 To (SubCatAmounts(i + 1) - 1)
Set SubCats = Cats.Controls.Add(Type:=msoControlPopup, Temporary:=True)
SubCats.Caption = SubCatArray(SC)
SubCats.Tag = j + 1
AmountOfMenus = MenuAmounts(SC)
For k = 0 To AmountOfMenus - 1
Set MenuDesc = SubCats.Controls.Add(Type:=msoControlButton)
With MenuDesc
.Caption = MenuArray(MD)
.Tag = MD
MyCaption = .Caption
.OnAction = AddStuff(MyCaption)
End With
MD = MD + 1
Next
SC = SC + 1
Next
Next
On Error GoTo 0
End Sub
Function AddStuff(Stuff As String)
Dim MyCell As String
MyCell = ActiveCell.Address
ActiveCell.Value = Stuff
End Function
OnAction expects a string value: instead you are calling your AddStuff sub while creating your menu...
.OnAction = "AddStuff """ & MyCaption & """"
is what you want (assuming I got my quotes right)
I was making a mistake with my AddStuff - I was calling it as a function when instead it should have been a macro (or a regular sub). A slight modification to Tim Williams' .OnAction code
MyButton.OnAction = "AddStuff(""" & MyButton.Caption & """)"
did the trick.

Resources