Error code 76 with VBA, not in every moment - excel

I'm having an issue with my code:
Sub lalalala ()
Dim s5 As Worksheet
Set s5 = ThisWorkbook.Sheets("Test")
Dim DesktopPath As String
Dim DesktopPathMAIN As String
Dim DesktopPathSUB As String
Dim file As String
Dim sfile As String
Dim sDFolder As String
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
DesktopPath = Environ("USERPROFILE") & "\Desktop\"
DesktopPathMAIN = DesktopPath & "THE FINAL TEST"
If Dir(DesktopPathMAIN, vbDirectory) = "" Then
Shell ("cmd /c mkdir """ & DesktopPathMAIN & """")
End If
lastrow = s5.Range("B" & s5.Rows.Count).End(xlUp).Row
Set rng = s5.Range("B1:B" & lastrow)
For Each c In rng
If Dir(DesktopPathMAIN & "\" & c.Offset(, 5).Value, vbDirectory) = "" Then
Shell ("cmd /c mkdir """ & DesktopPathMAIN & "\" & c.Offset(, 5).Value & """")
End If
Next c
lastrow = s5.Range("G" & s5.Rows.Count).End(xlUp).Row
Set rng = s5.Range("G1:G" & lastrow)
For Each c In rng
sDFolder = DesktopPathMAIN & "\" & c.Value & "\"
sfile = s5.Range("H1").Value & c.Offset(, -2).Value
Call oFSO.CopyFile(sfile, sDFolder)
Next c
End Sub
When i run the macro it causes error code 76, but if i run again it works perfectly. I realized it happens when the cell changes the value of the destination folder at this line sfile = s5.Range("H1").Value & c.Offset(, -2).Value.
But it only happens 1 time, if i run again it works perfectly.
How can i fix that?
thank you

Related

how make folders base on value of rows

firstly i want to write a macro for going through of every row so if valuse of item is more than 10 creat a folder base on values of that rows.in addition without a duplicate folder !
for example if there is item20 then create a folder with this name 20_NT25153_29.9 then another rows
i wanna to add this sentence ,i know my code is very simple but i am new in VBA hence need more help :)
Sub loopthrough()
With Worksheets("Output_" & Date)
fName5 = .Range("d").Value
fName1 = .Range("B").Value
fName2 = .Range("c").Value
fName4 = "_"
BrowseForFolder = CurDir()
End With
For Each cell In ActiveWorkbook.Worksheets
If cell.Range("B").Value > "10" Then
BrowseForFolder1 = BrowseForFolder & "\" & fName1 & fName2 & fName5
MkDir BrowseForFolder1
End If
Next cell
End Sub
You could use this code:
Sub Macro1()
Dim lLastRow As Long
Dim sPath As String, sNewFolder As String
sPath = CurDir()
lLastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lLastRow
If Range("B" & i).Value > 10 Then
sNewFolder = Range("B" & i).Value & "_" & Range("C" & i).Value & "_" & Range("D" & i).Value
If Dir(sPath & "\" & sNewFolder, vbDirectory) = "" Then
MkDir (sPath & "\" & sNewFolder)
End If
End If
sNewFolder = vbNullString
Next
End Sub
Fisrt of all I check for the last row index based on A column, not to loop through whole worksheet.
In a loop I've used a Dir() function with vbDirectory parameter which returns empty string when folder does not exists & in that case it creates a folder.
Is this what you're after?
Folder name is column B value _ column C value _ column D value ?
Sub loopthrough()
Dim cell As Range, fName4
BrowseForFolder = CurDir()
fName4 = "_"
With Worksheets("Output_" & Date)
For Each cell In .Range("B1", .Range("B" & Rows.Count).End(xlUp))
If cell.Value > 10 Then
BrowseForFolder1 = BrowseForFolder & "\" & cell.Value & fName4 & cell.Offset(, 1).Value & fName4 & cell.Offset(, 2).Value
MkDir BrowseForFolder1
End If
Next cell
End With
End Sub
it works for somebody need same as me
Sub Macro1()
Dim lLastRow As Long
Dim sPath As String, sNewFolder As String
sPath = CurDir()
lLastRow = workbooks(sFilename).Sheets(1).Range("A:A").SpecialCells(xlCellTypeLastCell).Row
Workbooks(sFilename).Sheets(1).Activate
For i = 2 To lLastRow
If Workbooks(sFilename).Sheets(1).Cells(i, 2).Value >= 10 Then
sNewFolder = ActiveSheet.Range("B" & i).Value & "_" & ActiveSheet.Range("C" &
i ).Value & "_" & ActiveSheet.Range("D" & i).Value
If Dir(sPath & "\" & sNewFolder, vbDirectory) = "" Then
MkDir (sPath & "\" & sNewFolder)
End If
End If
sNewFolder = vbNullString
Next
End Sub

Vba list all excel files in a folder?

I have the following code which is supposed to list all excel files in a folder.
Code:
Sub List()
'On Error GoTo Message
ActiveSheet.DisplayPageBreaks = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim i2 As Long
Dim i3 As Long
Dim j2 As Long
Dim name As String
Dim Txt As String
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(ThisWorkbook.Worksheets(1).Range("M4").value)
i = 18
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.files
'print file path
ThisWorkbook.Worksheets(1).Cells(i, 6) = objFile.path
'print file path
ThisWorkbook.Worksheets(1).Cells(i, 7) = Replace(objFile.name, ".xlsx", "")
'print file removal icon
ThisWorkbook.Worksheets(1).Cells(i, 30) = "Remove"
'Add Hyperlink
ThisWorkbook.Worksheets(1).Hyperlinks.Add Anchor:=Cells(i, 27), Address:=objFile.path, TextToDisplay:="Open Announcement"
'Lookup contact info
ThisWorkbook.Worksheets(1).Cells(i, 11).Formula = "=IFERROR(INDEX(Contacts!$C:$C,MATCH(""*"" & """ & Range("G" & i).value & """ & ""*"",Contacts!$B:$B,0)),IFERROR(INDEX(Contacts!$C:$C,MATCH(""" & Left(Range("G" & i).value, 7) & """ & ""*"",Contacts!$B:$B,0)),""""))"
ThisWorkbook.Worksheets(1).Cells(i, 14).Formula = "=IF(""" & Range("K" & i).value & """ = """","""",IFERROR(INDEX(Contacts!$D:$D,MATCH(""*"" & """ & Range("K" & i).value & """ & ""*"",Contacts!$C:$C,0)),""""))"
ThisWorkbook.Worksheets(1).Cells(i, 18).Formula = "=IF(""" & Range("K" & i).value & """ = """","""",IFERROR(INDEX(Contacts!$E:$E,MATCH(""*"" & """ & Range("K" & i).value & """ & ""*"",Contacts!$C:$C,0)),""""))"
ThisWorkbook.Worksheets(1).Cells(i, 23) = "=IF(K" & i & "="""",""Missing Contact! "","""")&IF(INDEX(Data!L:L,MATCH(G" & i & ",Data!F:F,0))=""TBC"",""Missing Data! "","""")&IF(U" & i & ">=DATE(2017,1,1),"""",""Check Date!"")"
'Delivery Dates
ThisWorkbook.Worksheets(1).Cells(i, 21).Formula = "=IFERROR(INDEX(Data!$Q:$Q,MATCH(""*"" & """ & Range("G" & i).value & """ & ""*"",Data!$F:$F,0)),IFERROR(INDEX(Data!$Q:$Q,MATCH(""*"" & """ & Left(Range("G" & i).value, 7) & """ & ""*"",Data!$F:$F,0)),""""))"
ThisWorkbook.Worksheets(1).Cells(i, 25) = "Sync"
i = i + 1
Next objFile
ThisWorkbook.Worksheets(1).Calculate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
Message:
Application.DisplayAlerts = False
Exit Sub
End Sub
For some reason, despite there being several excel files in the folder, only one file is being listed.
Please can someone show me where i am going wrong?
Start with something simple and then make it more and more complicated. The following works for me, displaying all the files you have in the folder. They are printed in the immediate window (Ctrl+G) in the Visual Basic Editor. From there, you can go further:
Option Explicit
Sub List()
On Error GoTo Message
ActiveSheet.DisplayPageBreaks = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Long
Dim i2 As Long
Dim i3 As Long
Dim j2 As Long
Dim name As String
Dim Txt As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\Users\TestMe\Arch")
For Each objFile In objFolder.Files
Debug.Print objFile
Next objFile
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
Message:
Application.DisplayAlerts = False
Exit Sub
End Sub

Rename files in Mac OS

I have written code which reads file names from column A and renames it to column B, if file specified in column A exists in Input folder.
Sub Rename_click()
Dim inputFolder$, iFile$, oFile$
Dim iRow&, lRow&
inputFolder = ThisWorkbook.Path & Application.PathSeparator & "Input"
With shInput
If .FilterMode Then .ShowAllData
lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For iRow = 2 To lRow
iFile = .Cells(iRow, "A")
oFile = .Cells(iRow, "B")
If iFile <> "" And oFile <> "" Then
If Dir(inputFolder & Application.PathSeparator & iFile) <> "" Then
Name inputFolder & Application.PathSeparator & iFile As inputFolder & Application.PathSeparator & oFile
End If
End If
Next
End With
End Sub
It works in Windows. How can I make it Mac compatible?

File already exists

I've created a macro that distributes a group of files into various subfolders. However, I'm getting a "file already exists" error when trying to move the file. It occurs on the 2nd and 3rd oFSO.movefile statements. Any Ideas? I tried adding a "\" to the end of the filename but then it gives me a type mismatch error?
PS. please bear with me, I don't have any formal training in VBA.
thanks!
Sub DistributeDD()
MsgBox ("To use this Macro, Place all loan numbers you want to create folders for in column A starting at A1 and the sponsor in column B or C")
SourceFolder = InputBox("Paste the Path where the files are located")
Dim oFSO
Dim oFolder As Object
Dim oFile As Object
Dim NewFolder As String
Dim myRange As Range
Dim i As Long
Dim TestString As String
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Dim subfolder As String
Dim Sponsor As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(SourceFolder)
For i = 1 To LastRow
LoanID = Cells(i, 1).Value
Sponsor = Cells(i, 2).Value
Sponsor2 = Cells(i, 3).Value
For Each oFile In oFolder.Files
TestString = oFile.Name
'Populate Collateral File
If InStr(UCase(TestString), UCase(LoanID)) > 0 Then
NewFolder = LoanID
subfolder = IdentifySubfolder(TestString)
createNewDirectory (SourceFolder & "\" & NewFolder)
createNewDirectory (SourceFolder & "\" & NewFolder & "\" & subfolder)
oFSO.movefile Source:=oFile, Destination:=SourceFolder & "\" & NewFolder & "\" & subfolder & "\"
End If
'Populate Sponsor
If InStr(UCase(TestString), UCase(Sponsor)) > 0 Then
NewFolder = LoanID
subfolder = IdentifySubfolder(TestString)
createNewDirectory (SourceFolder & "\" & NewFolder)
createNewDirectory (SourceFolder & "\" & NewFolder & "\" & Sponsor)
oFSO.movefile Source:=oFile, Destination:=SourceFolder & "\" & NewFolder & "\" & Sponsor
MsgBox (TestString)
End If
'Populate Sponsor2
If InStr(UCase(TestString), UCase(Sponsor)) > 0 Then
NewFolder = LoanID
subfolder = IdentifySubfolder(TestString)
createNewDirectory (SourceFolder & "\" & NewFolder)
createNewDirectory (SourceFolder & "\" & NewFolder & "\" & Sponsor2)
createNewDirectory (SourceFolder & "\" & NewFolder & "\" & Sponsor2 & "\" & subfolder)
oFSO.movefile Source:=oFile, Destination:=SourceFolder & "\" & NewFolder & "\" & Sponsor2
End If
Next oFile
Next i
Set oFolder = Nothing
Set oFSO = Nothing
End Sub
Is it possible that columns Sponsor (2) and Sponsor2 (3) have the same information? If so, the folder created under the SourceFolder\NewFolder will have the same name.
Also, I don't know why you're testing those columns with the file's name, but at line 42 you're testing with 'Sponsor' again.
If InStr(UCase(TestString), UCase(Sponsor)) > 0 Then
Depending on your data, it might be the source of the problem.

Excel VBA Filename Search Return Path

I am looking for help with VBA to find file names listed in an excel Column A from a folder and return the file path in Column B
The code below works, however if I would like excel to skip the row if the filename cannot be found so that the filepath results are returned in the cell directly next to the filename.
Private Sub CommandButton1_Click()
Dim sh As Worksheet, rng As Range, lr As Long, fPath As String
Set sh = Sheets(1) 'Change to actual
lstRw = sh.Cells.Find(What:="*", After:=sh.Range("A1"), LookAt:=xlWhole, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
Set rng = sh.Range("A2:A" & lstRw)
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
fPath = .SelectedItems(1)
End With
If Right(fPath, 1) <> "\" Then
fPath = fPath & "\"
End If
fwb = Dir(fPath & "*.*")
x = 2
Do While fwb <> ""
For Each c In rng
If InStr(LCase(fwb), LCase(c.Value)) > 0 Then
Worksheets("Sheet2").Range("A" & x) = fwb
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(fPath & fwb)
Worksheets("Sheet1").Range("B" & x) = f.Path
Set fs = Nothing
Set f = Nothing
x = x + 1
End If
Next
fwb = Dir
Loop
Set sh = Nothing
Set rng = Nothing
Sheets(2).Activate
End Sub
As mentioned in my comments above, use the DIR inside the range loop. See this example.
Here it won't output anything to Col B if the respective cell in Col A doesn't return anything.
Sub Sample()
Dim sh As Worksheet
Dim rng As Range
Dim i As Long, Lrow As Long
Dim fPath As String, sPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
fPath = .SelectedItems(1)
End With
If Right(fPath, 1) <> "\" Then
fPath = fPath & "\"
End If
Set sh = ThisWorkbook.Sheets("Sheet1")
With sh
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To Lrow
'~~> Check for partial match
sPath = fPath & "*" & .Range("A" & i).Value & "*.*"
If Len(Trim(Dir(sPath))) > 0 Then
.Range("B" & i).Value = Dir(sPath)
End If
Next i
End With
End Sub
Note: If you do not want a partial match then consider revising
sPath = fPath & "*" & .Range("A" & i).Value & "*.*"
to
sPath = fPath & .Range("A" & i).Value & ".*"

Resources