In the below excel 2010 vba all the text files are opened and read by the loop and then a call to a module that is in the same sheet is made. However I am getting an Argument not optional' error on that line (Call CreateXLSXFiles`). I need some expert help in fixing this as I can not figure it out. Thank you :)
VBA
'CREATE REPORT '
MsgBox ("Please click ok to generate analysis reports, vbOKOnly")
Dim myDir As String, fn As String
myDir = "C:\Users\cmccabe\Desktop\EmArray\"
fn = Dir(myDir & "*.txt")
Do While fn <> ""
CreateXLSXFiles myDir & fn
fn = Dir
Loop
Call CreateXLSXFiles
Module
Sub CreateXLSXFiles(fn As String)
' PARSE TEXT FILE AND CREATE XLSX REPORT '
Dim txt As String, m As Object, n As Long, fp As String
Dim i As Long, x, temp, ub As Long, myList
myList = Array("Display Name", "Medical Record", "Date of Birth", _
"Order Date", "Gender", "Barcode", "Sample", "Build", _
"SpikeIn", "Location", "Control Gender", "Quality")
fp = "C:\Users\cmccabe\Desktop\EmArray\"
With Worksheets(1)
.Cells.Clear
.Name = CreateObject("Scripting.FileSystemObject").GetBaseName(fn)
On Error Resume Next
n = FileLen(fn)
If Err Then
MsgBox "Something wrong with " & fn
Exit Sub
End If
On Error GoTo 0
n = 0
txt = CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll
With CreateObject("VBScript.RegExp")
.Global = True: .MultiLine = True
For i = 0 To UBound(myList)
.Pattern = "^#(" & myList(i) & " = (.*))"
If .Test(txt) Then
n = n + 1
Sheets(1).Cells(n, 1).Resize(, 2).Value = _
Array(.Execute(txt)(0).submatches(0), .Execute(txt)(0).submatches(1))
End If
Next
.Pattern = "^[^#\r\n](.*[\r\n]+.+)+"
x = Split(.Execute(txt)(0), vbCrLf)
.Pattern = "(\t| {2,})"
temp = Split(.Replace(x(0), Chr(2)), Chr(2))
n = n + 1
For i = 0 To UBound(temp)
Sheets(1).Cells(n, i + 1).Value = temp(i)
Next
ub = UBound(temp)
.Pattern = "((\t| {2,})| (?=(\d|"")))"
For i = 1 To UBound(x)
temp = Split(.Replace(x(i), Chr(2)), Chr(2))
n = n + 1
Sheets(1).Cells(n, 1).Resize(, ub).Value = temp
Next
End With
.Copy
Application.DisplayAlerts = False
With ActiveSheet
.Columns.AutoFit
.Range("B1:B12").ClearContents
End With
ActiveWorkbook.SaveAs Filename:=fp & .Name, _
FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close False
End Sub
The method CreateXLSXFiles takes a String as input :
Sub CreateXLSXFiles(fn As String)
However, you're calling it without passing any string:
Call CreateXLSXFiles
In order to make it work, you need to pass the needed fn (that I guess it means "file name") :
Call CreateXLSXFiles(fn)
or with the newest syntax, simply:
CreateXLSXFiles fn
Related
So I have created a dynamic selection list for excel using vba. see below
Below is the code
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Address = "$A$2" Then
Call PanggilPhoto
End If
End Sub
Sub PanggilPhoto()
Application.ScreenUpdating = False
Dim myObj
Dim Foto
Set myObj = ActiveSheet.DrawingObjects
For Each Foto In myObj
If Left(Foto.Name, 7) = "Picture" Then
Foto.Select
Foto.Delete
End If
Next
Dim CommodityName1 As String, CommodityName2 As String, T As String
myDir = ThisWorkbook.Path & "\"
CommodityName1 = Range("A2")
T = ".png"
Range("C15").Value = CommodityName
On Error GoTo errormessage:
ActiveSheet.Shapes.AddPicture Filename:=myDir & CommodityName1 & T, _
linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=190, Top:=10, Width:=140,
Height:=90
errormessage:If Err.Number = 1004 Then
Exit Sub
MsgBox "File does not exist." & vbCrLf & "Check the name of the Commodity!"
Range("A2").Value = ""
Range("C10").Value = ""
End If
Application.ScreenUpdating = True
End Sub
foto is a predefined data list in the sheet.
So the question is instead of doing it for one cell how can I create a loop of some sort to do it for multiple cells? I need it to import mulitple images on one macro run
found a solution
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Address = "$A$2" Then
Call schedules
End If
End Sub
Sub schedules()
Worksheets("Picture").Activate
Application.ScreenUpdating = False
Dim myObj
Dim Foto
Set myObj = ActiveSheet.DrawingObjects
For Each Foto In myObj
If Left(Foto.Name, 7) = "Picture" Then
Foto.Select
Foto.Delete
End If
Next
Dim CommodityName1 As String, CommodityName2 As String, T1 As String, T2 As String
Dim i As Integer, j As Integer, k As Integer
j = 0
For i = 2 To 100
myDir = "C:\Users\User\Desktop\ESTIMATING SHEETS\test\rebar shapes" & "\"
CommodityName1 = Range("A" & i)
T1 = ".png"
On Error GoTo errormessage:
ActiveSheet.Shapes.AddPicture Filename:=myDir & CommodityName1 & T1, _
linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=230, Top:=j, Width:=140, Height:=80
errormessage:
If Err.Number = 1004 Then
Exit Sub
MsgBox "File does not exist." & vbCrLf & "Check the name of the rebar!"
Range("A" & i).Value = ""
Range("C10").Value = ""
End If
Application.ScreenUpdating = True
i = i + 11
j = j + 190
Next i
End Sub
I have a VBA project where I need to create a userform on which there should be an attachment button to select multiple images and save them in a folder with a specific name. Later, if a person looks up that name from the search box, it should call all the information saved along with the images. The names should be as follows Sh-0001-01 (where 0001 represents invoice number and 01 denotes attachment number).
I have got a file from another forum that can load images into the image box and scroll across them but there is no mechanism to add new images except copying new images to the back-end folder. And also, no functionality to save attachments with a specific name and look them up using that name.
The outcome is attached as an image. The example code file can be accessed via this link:
https://drive.google.com/file/d/1HXLjDIpjNmgxLxegYiexxEykh4f_54sY/view?usp=sharing
As it was mandatory by Stackoverflow to include a sample code, here is part of the code that is in the file in the drive:
Public Const fPath As String = "C:\Test\"
Sub LaunchForm()
UserForm1.Show
End Sub
Function PhotoNum(numx As Integer) As String
Dim PhotoNames As String, iFile As String
Dim i As Integer
Dim ArrayPhoto() As Variant
iFile = "*.*"
PhotoNames = Dir(fPath & iFile)
i = 0
Do Until PhotoNames = ""
i = i + 1
ReDim Preserve ArrayPhoto(1 To i)
ArrayPhoto(i) = PhotoNames
PhotoNames = Dir
Loop
PhotoNum = ArrayPhoto(numx)
End Function
Function MaxPhoto() As Integer
Dim PhotoNames As String, iFile As String
Dim i As Integer
Dim ArrayPhoto() As Variant
iFile = "*.*"
PhotoNames = Dir(fPath & iFile)
i = 0
Do Until PhotoNames = ""
i = i + 1
ReDim Preserve ArrayPhoto(1 To i)
ArrayPhoto(i) = PhotoNames
PhotoNames = Dir
Loop
MaxPhoto = UBound(ArrayPhoto)
End Function
Any help is appreciated.
Please, try the next way. A text box named "tbOrder" must exist. In it the order/invoice number must be entered (manually or by code). The rest of controls are the one used in your sent testing workbook. Please, copy the next code in the form code module. Only a sub showing the form should exist in a standard module. A new button (btAttach) to add attachment has been added and a check box (chkManyAtt) where to specify the multiple selection option:
Option Explicit
Private Const fPath As String = "C:\test\"
Private photoNo As Long, arrPhoto() As Variant, boolNoEvents As Boolean, prevVal As Long, boolFound As Boolean
Private boolManyAttch As Boolean
Private Sub btAttach_Click()
If Len(tbOrder.Text) <> 7 Then MsgBox "An invoice number is mandatory in its specific text box (7 digits long)": Exit Sub
Dim noPhotos As Long, runFunc As String
runFunc = bringPicture(Left(tbOrder.Text, 7), True)
If Not boolFound Then noPhotos = -1
Dim sourceFile As String, destFile As String, attName As String, strExt As String, i As Long
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Please, select the picture to be added as attachment for invoice " & Me.tbOrder.Text & " (" & photoNo & ")"
.AllowMultiSelect = IIf(boolManyAttch = True, True, False)
.Filters.Add "Picture Files", "*.jpg", 1
If .Show = -1 Then
For i = 1 To .SelectedItems.Count
sourceFile = .SelectedItems(i): 'Stop
attName = Me.tbOrder.Text & "-" & Format(IIf(noPhotos = -1, 1, photoNo + 1), "00")
strExt = "." & Split(sourceFile, ".")(UBound(Split(sourceFile, ".")))
destFile = fPath & attName & strExt
FileCopy sourceFile, destFile
ReDim Preserve arrPhoto(IIf(noPhotos = -1, 0, UBound(arrPhoto) + 1)): noPhotos = 0
arrPhoto(UBound(arrPhoto)) = attName & strExt
photoNo = photoNo + 1
Next i
Else
Exit Sub
End If
End With
Me.TextBox2.Text = photoNo: Me.TextBox2.Enabled = False
Me.TextBox1.Text = photoNo
End Sub
Private Sub chkManyAtt_Click()
If Me.chkManyAtt.Value Then
boolManyAttch = True
Else
boolManyAttch = False
End If
End Sub
Private Sub CommandButton1_Click() 'Prev button
Dim currPic As Long
currPic = Me.TextBox1.Value
If currPic > 1 Then
Me.Image1.Picture = LoadPicture(fPath & arrPhoto(currPic - 2))
boolNoEvents = True 'stop the events when TextBox1 is changed
Me.TextBox1.Text = currPic - 1
prevVal = Me.TextBox1.Value
boolNoEvents = False 'restart events
End If
End Sub
Private Sub CommandButton2_Click() 'Next button
Dim currPic As Long
currPic = Me.TextBox1.Value
If currPic < photoNo Then
Me.Image1.Picture = LoadPicture(fPath & arrPhoto(currPic))
boolNoEvents = True
Me.TextBox1.Text = currPic + 1
prevVal = Me.TextBox1.Value
boolNoEvents = False
Else
MsgBox "Please, select a valid image number..."
End If
End Sub
Private Sub tbOrder_Change() 'the textbox where to input the order/invoice nubmer
Dim firstPict As String
If Len(tbOrder.Text) >= 7 Then
photoNo = 0: Erase arrPhoto 'clear the variable keeping the number of found photos and the array keeping them
firstPict = bringPicture(Left(tbOrder.Text, 7)) 'to make it working even if you paste "Sh-0002-20"
If firstPict <> "" Then 'determining the first picture to be placed
With Me.Image1
.Picture = LoadPicture(fPath & firstPict)
.PictureSizeMode = fmPictureSizeModeZoom
End With
boolNoEvents = True 'avoiding the event to be triggeret twice
Me.TextBox1.Text = 1
With Me.TextBox2
.Enabled = True
.Text = photoNo
.Enabled = False
End With
boolNoEvents = False
Else
Me.Image1.Picture = LoadPicture(vbNullString) 'clear the picture if no order/invoice have been written in the text box
Me.TextBox2.Text = "": Me.TextBox1.Text = ""
End If
End If
End Sub
Function bringPicture(strName As String, Optional boolAttach As Boolean = False) As String
Dim PhotoNames As String, arrPh, noPict As Long, firstPict As String, ph As Long
PhotoNames = Dir(fPath & strName & "*.*") 'find the first photo with the necessary pattern name
If boolAttach Then
ReDim arrPhoto(0): photoNo = 0
Else
ReDim arrPhoto(photoNo) 'firstly ReDim the array
End If
boolFound = False
Do While PhotoNames <> ""
boolFound = True
arrPhoto(photoNo) = PhotoNames: photoNo = photoNo + 1
ReDim Preserve arrPhoto(photoNo)
PhotoNames = Dir()
Loop
If photoNo > 0 Then
ReDim Preserve arrPhoto(photoNo - 1) 'eliminate the last empty array element
bringPicture = arrPhoto(0) 'return the first photo in the array
End If
End Function
Private Sub TextBox1_Change() 'manually change the picture number
If Not boolNoEvents Then 'to not be treggered when changed by code
If IsNumeric(Me.TextBox1.Value) Then 'to allow only numbers
If Len(Me.TextBox1.Value) >= Len(CStr(photoNo)) Then 'to allow numbers less or equal with the maximum available
If CLng(TextBox1.Text) > photoNo Then
MsgBox "Select valid image number"
boolNoEvents = True
Me.TextBox1.Text = prevVal
boolNoEvents = False
Else
Me.Image1.Picture = LoadPicture(fPath & arrPhoto(Me.TextBox1.Value - 1))
Me.Image1.PictureSizeMode = fmPictureSizeModeZoom
End If
prevVal = Me.TextBox1.Value
End If
Else
Me.TextBox1.Text = ""
End If
End If
End Sub
If something not clear enough, please do not hesitate to ask for clarifications.
I am using the below code to parse multiple documents within a folder and copy the whole matching rows to the open spreadsheet.
I have seen on the microsoft website that this could be part of a known issue and saving inside the code could resolve the issue. However I am stumped on how to do so.
Strangely the macro will work on all of the files in the defined folder on their own just not together.
The part of the code that is causing issue is bold.
Any help would be greatly appreciated.
Thanks
Steve
Dim myDir As String, fn As String, ws As Worksheet, r As Range
Dim a(), n As Long, x As Long, myTask As String, ff As String, temp
myDir = "C:\Users\stacys.CAMKMG-BLR\Desktop\MyFolder\" '<- change path to folder with files to search
If Dir(myDir, 16) = "" Then
MsgBox "No such folder path", 64, myDir
Exit Sub
End If
myTask = InputBox("Enter Policy Type")
If myTask = "" Then Exit Sub
x = Columns.Count
fn = Dir(myDir & "*.xls*")
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Do While fn <> ""
With Workbooks.Open(myDir & fn, 0)
For Each ws In .Worksheets
Set r = ws.Cells.Find(myTask, , , 1)
If Not r Is Nothing Then
ff = r.Address
Do
n = n + 1
temp = r.EntireRow.Value
ReDim Preserve temp(1 To 1, 1 To x)
ReDim Preserve a(1 To n)
a(n) = temp
Set r = ws.Cells.FindNext(r)
Loop While ff <> r.Address
End If
Next
.Close False
End With
fn = Dir
Loop
With ThisWorkbook.Sheets(1).Rows(1)
.CurrentRegion.ClearContents
If n > 0 Then
**.Resize(n).Value = _
Application.Transpose(Application.Transpose(a))**
Else
MsgBox "Not found", , myTask
End If
End With
End Sub
I need this macro to automatically grab the data from column A, find the data into the path given and replace it with column B. It is working but I need it to work just for once and goes on forward automatically..
Can anyone help me in this..
Sub UnkownFunctionName()
Dim myfolder
Dim Fnd As String, Rplc As String
Fnd = Application.InputBox(prompt:="Find string:", Title:="Rename files and folders", Type:=2)
Rplc = Application.InputBox(prompt:="Replace with:", Title:="Rename files and folders", Type:=2)
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
myfolder = .SelectedItems(1) & "\"
End With
Call Recursive(myfolder, Fnd, Rplc)
End Sub
Sub Recursive(FolderPath As Variant, Fnd As String, Rplc As String)
Dim Value As String, Folders() As String, Fname As String, Fext As String, Mtxt As String
Dim x As Integer
Dim Folder As Variant, a As Long
ReDim Folders(0)
If Right(FolderPath, 2) = "\\" Then Exit Sub
Value = Dir(FolderPath, &H1F)
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If GetAttr(FolderPath & Value) = 16 Or GetAttr(FolderPath & Value) = 48 Then
On Error Resume Next
Mtxt = "Rename folder " & Value & " to " & WorksheetFunction.Substitute(Value, Fnd, Rplc) & "?"
x = MsgBox(Mtxt, vbYesNoCancel)
If x = vbCancel Then Exit Sub
If x = vbYes Then
Name FolderPath & Value As FolderPath & WorksheetFunction.Substitute(Value, Fnd, Rplc)
End If
Value = WorksheetFunction.Substitute(Value, Fnd, Rplc)
If Err <> 0 Then
MsgBox "Error"
Exit Sub
End If
On Error GoTo 0
Folders(UBound(Folders)) = Value
ReDim Preserve Folders(UBound(Folders) + 1)
Else
On Error Resume Next
Fext = Split(Value, ".")(UBound(Split(Value, ".")))
Fname = Left(Value, Len(Value) - Len(Split(Value, ".")(UBound(Split(Value, ".")))) - 1)
Fname = WorksheetFunction.Substitute(Fname, Fnd, Rplc)
If Value <> (Fname & "." & Fext) Then
Mtxt = "Rename file " & Value & " to " & Fname & "." & Fext & "?"
x = MsgBox(Mtxt, vbYesNoCancel)
If x = vbCancel Then Exit Sub
If x = vbYes Then
Name FolderPath & Value As FolderPath & Fname & "."& Fext
End If
End If
If Err <> 0 Then
MsgBox "Error"
Exit Sub
End If
On Error GoTo 0
End If
End If
Value = Dir
Loop
For Each Folder In Folders
Call Recursive(FolderPath & Folder & "\", Fnd, Rplc)
Next
End Sub
If this accomplishes what you want, why not put a pause of some kind after the loop that accomplishes your goal completes. For instance-
...
End If
If MsgBox("Continue?", vbYesNo, "Confirm") = vbNo Then Exit Sub
...
I'm having a hard time linking what the code does to what your question suggests. It seems that the code renames files and folders. Can you explain a bit more about your goal?
Below is a function built by others that changes text into sentence case (first letter of each sentence capitalized). The function works nicely except it doesn't capitalize the first letter of the first word. Another issue is that if a sentence is entered in all caps, the function does nothing. I'm looking for some assistance in tweaking the function to correct these issues.
Option Explicit
Function ProperCaps(strIn As String) As String
Dim objRegex As Object
Dim objRegMC As Object
Dim objRegM As Object
Set objRegex = CreateObject("vbscript.regexp")
strIn = LCase$(strIn)
With objRegex
.Global = True
.ignoreCase = True
.Pattern = "(^|[\.\?\!\r\t]\s?)([a-z])"
If .test(strIn) Then
Set objRegMC = .Execute(strIn)
For Each objRegM In objRegMC
Mid$(strIn, objRegM.firstindex + 1, objRegM.Length) = UCase$(objRegM)
Next
End If
End With
ProperCaps = strIn
End Function
Thanks,
Gary
I renamed the function to SentenceCase() and made a few more adjustments:
Public Function SentenceCase(ByVal str As String) As String
Dim regEx As Object, regExM As Object, indx As Object, indxs As Object
Set regEx = CreateObject("VBScript.RegExp")
str = Replace$(str, vbNullChar, vbLf)
str = Replace$(str, vbBack, vbLf)
str = LTrim$(LCase$(str))
With regEx
.IgnoreCase = True
.MultiLine = True
.Global = True
.Pattern = "(^|[\n\f\r\t\v\.\!\?]\s*)(\w)"
If .Test(str) Then
Set indxs = .Execute(str)
For Each indx In indxs
Mid$(str, indx.FirstIndex + 1, indx.Length) = UCase$(indx)
Next
End If
End With
SentenceCase = str
End Function
This is what I tested it with:
MsgBox SentenceCase(" UPPER CASE SENTENCE." & _
vbCrLf & "next line!nEXT sENTENCE" & _
vbCr & "cr ! lower case" & _
vbLf & "lf .new sentence" & _
vbNullChar & " null?null char" & _
vbNullString & "nullString spaces" & _
vbTab & "TAB CHAR.ttt" & _
vbBack & "back? back char" & _
vbFormFeed & "ff ff words" & _
vbVerticalTab & "vertical tab.| lower .case words")
Results:
You can find more details here: Microsoft - Regular Expressions
Paul thank you for taking the time to help. I gave up and searched the net some more found a workable sub, received help from another bulletin board and came up with the following:
Sub SentenceCase(rng As Range)
Dim V As Variant
Dim s As String
Dim Start As Boolean
Dim i As Long
Dim ch As String
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.Unprotect
With rng
V = .Value
If IsDate(V) Or IsNumeric(V) Then Exit Sub
s = CStr(V)
Start = True
For i = 1 To Len(s)
ch = Mid$(s, i, 1)
Select Case ch
Case "."
Start = True
Case "?"
Start = True
Case "!"
Start = True
Case "a" To "z"
If Start Then ch = UCase$(ch)
Start = False
Case "A" To "Z"
If Start Then
Start = False
Else
ch = LCase$(ch)
End If
End Select
Mid$(s, i, 1) = ch
Next i
.Value = s
End With
ActiveSheet.Protect
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
This code is doing what I needed. Again thank you for your help.
Gary