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.
Related
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
So i have found 2 macros which i want to use to save and create a back up files for the said file.
The Macro which i want to primarily use is this one:
Sub DateFolderSave()
Dim strGenericFilePath As String: strGenericFilePath = "D:\"
Dim strYear As String: strYear = Year(Date) & "\"
Dim strMonth As String: strMonth = MonthName(Month(Date)) & "\"
Dim strDay As String: strDay = Day(Date) & "\"
Dim strFileName As String: strFileName = "_Dispatch Process_"
Application.DisplayAlerts = False
' Check for year folder and create if needed
If Len(Dir(strGenericFilePath & strYear, vbDirectory)) = 0 Then
MkDir strGenericFilePath & strYear
End If
' Check for month folder and create if needed
If Len(Dir(strGenericFilePath & strYear & strMonth, vbDirectory)) = 0 Then
MkDir strGenericFilePath & strYear & strMonth
End If
' Check for date folder and create if needed
If Len(Dir(strGenericFilePath & strYear & strMonth & strDay, vbDirectory)) = 0 Then
MkDir strGenericFilePath & strYear & strMonth & strDay
End If
' Save File
ActiveWorkbook.SaveAs FileName:= _
strGenericFilePath & strYear & strMonth & strDay & strFileName, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Application.DisplayAlerts = True
' Popup Message
MsgBox "File Saved As: " & vbNewLine & strGenericFilePath & strYear & strMonth & strDay & strFileName
End Sub
So i found this another Macro which make continuous back up of the files and has a custom format to a file name
Sub Save_Backup(ByVal Backup_Folder_Path As String)
Dim fso As Object
Dim ExtensionName As String, FileName As String
Dim wbSource As Workbook
Set fso = CreateObject("Scripting.FileSystemObject")
Set wbSource = ThisWorkbook
ExtensionName = fso.GetExtensionName(wbSource.Name)
FileName = Replace(wbSource.Name, "." & ExtensionName, "")
fso.CopyFile ThisWorkbook.FullName, _
fso.BuildPath(Backup_Folder_Path, FileName & " (" & Format(Now(), "dd-mmm-yy hh.mm AM/PM") & ")." & ExtensionName)
Set fso = Nothing
Set wbSource = Nothing
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Call Save_Backup("C:\Users\admin\Downloads\Back Up\New Backup")
End Sub
So i want to create back up like the first macro(i.e. Folder inside a folders for the specific date) but want to have a continuous stream of files for back up(i.e. Want the date folder to create new save file each time i save the Document)
Is there a way to combine both these macros?
I'm just getting started on learning VBA and am a bit stumped on the following. I'd be grateful for your assistance.
With the following I'm getting: Compile Error: Duplication in Current Scope after ElseIf (ActiveSheet.Name) = "BA Tracker" Then at line folderPathWithName As String.
My assumption had been that what's in the initial If wouldn't impact the subsequent ElseIf. If that isn't the case then I'm really not sure what to take out of the ElseIf to make this work.
Thanks for your help.
Sub CopyFile()
Dim oFSO As Object
Dim SourceFile As String
Dim DestinationFolder As String
Dim startPath As String
Dim myName As String
Dim FileYear As String
Dim FileMonth As String
Dim AgentName As String
Dim Agreement As String
Dim CallDate As String
Dim wb As Workbook
Dim ws1112 As Worksheet
Dim ws2221 As Worksheet
Dim s As String
Dim r As String
Dim cst As String
Dim cd As String
Dim ass As String
Dim ty As String
Dim an As String
Dim ss As String
Dim si As String
Dim sour As String
FileYear = Range("A2")
FileMonth = Range("A3")
AgentName = Range("D1")
Agreement = Range("D2")
CallDate = Range("D3")
If (ActiveSheet.Name) = "Sitel Audit" Then
startPath = "C:\Users\matthew.varnham\Desktop\QA Improvements\" & FileYear & "\" & FileMonth & "\"
myName = ActiveSheet.Range("D1").Text ' Change as required to cell holding the folder title
' check if folder exists, if yes, end, if not, create
Dim folderPathWithName As String
folderPathWithName = startPath & Application.PathSeparator & myName
If Dir(folderPathWithName, vbDirectory) = vbNullString Then
MkDir folderPathWithName
End If
Set oFSO = CreateObject("Scripting.FileSystemObject")
SourceFile = "C:\Users\matthew.varnham\Desktop\QA Improvements\Customer service Inbound scorecard v9.xlsm"
DestinationFolder = "C:\Users\matthew.varnham\Desktop\QA Improvements\" & FileYear & "\" & FileMonth & "\" & AgentName & "\"
oFSO.CopyFile Source:=SourceFile, Destination:=DestinationFolder & "\" & AgentName & " - " & Agreement & ".xlsm"
ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell.Offset(0, 12), Address:=("C:\Users\matthew.varnham\Desktop\QA Improvements\" & FileYear & "\" & FileMonth & "\" & AgentName & "\" & AgentName & " - " & Agreement & ".xlsm"), TextToDisplay:="OPEN"
Set ws1112 = Sheets("Sitel Audit")
s = ws1112.Range("D1").Value 'Agent Name
r = ws1112.Range("D3").Value 'Call Date
cst = ws1112.Range("D4").Value 'Call Start Time
cd = ws1112.Range("D5").Value 'Call Duration
ass = ws1112.Range("D6").Value 'Assessor Initials
ty = ws1112.Range("D7").Value 'Call Type
an = ws1112.Range("D2").Value 'Agreement Number
ss = ws1112.Range("D8").Value 'Sitel Score
si = ws1112.Range("E1").Value & FileYear & "\" & FileMonth & "\" & AgentName & "\" 'Sitel QA Folder
sour = ws1112.Range("A4").Value 'Sitel as Source
Set wb = Workbooks.Open("C:\Users\matthew.varnham\Desktop\QA Improvements\" & FileYear & "\" & FileMonth & "\" & AgentName & "\" & AgentName & " - " & Agreement & ".xlsm")
Set ws2221 = wb.Sheets("Observation Sheet")
ws2221.Range("B5:C5").Value = s 'Agent Name
ws2221.Range("E5").Value = r 'Call Date
ws2221.Range("F5").Value = cst 'Call Start Time
ws2221.Range("G5").Value = cd 'Call Duration
ws2221.Range("B8:C8").Value = ass 'Assessor Initials
ws2221.Range("B11:C11").Value = ty 'Call Type
ws2221.Range("E8:G8").Value = an 'Agreement Number
ws2221.Range("D4").Value = ss 'Sitel Score
ws2221.Range("G51").Value = si 'Sitel QA Folder
ws2221.Range("C3").Value = sour 'Sitel as Source
ElseIf (ActiveSheet.Name) = "BA Tracker" Then
startPath = "C:\Users\matthew.varnham\Desktop\QA Improvements\BA Tracker\" & FileYear & "\" & FileMonth & "\"
myName = ActiveSheet.Range("D1").Text ' Change as required to cell holding the folder title
' check if folder exists, if yes, end, if not, create
Dim folderPathWithName As String
folderPathWithName = startPath & Application.PathSeparator & myName
If Dir(folderPathWithName, vbDirectory) = vbNullString Then
MkDir folderPathWithName
End If
Set oFSO = CreateObject("Scripting.FileSystemObject")
SourceFile = "C:\Users\matthew.varnham\Desktop\QA Improvements\Customer service Inbound scorecard v9.xlsm"
DestinationFolder = "C:\Users\matthew.varnham\Desktop\QA Improvements\BA Tracker\" & FileYear & "\" & FileMonth & "\" & AgentName & "\"
oFSO.CopyFile Source:=SourceFile, Destination:=DestinationFolder & "\" & AgentName & " - " & Agreement & ".xlsm"
ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell.Offset(0, 13), Address:=("C:\Users\matthew.varnham\Desktop\QA Improvements\BA Tracker\" & FileYear & "\" & FileMonth & "\" & AgentName & "\" & AgentName & " - " & Agreement & ".xlsm"), TextToDisplay:="OPEN"
Set ws1112 = Sheets("BA Tracker")
s = ws1112.Range("D1").Value 'Agent Name
r = ws1112.Range("D3").Value 'Call Date
cst = ws1112.Range("D4").Value 'Call Start Time
cd = ws1112.Range("D5").Value 'Call Duration
ass = ws1112.Range("D6").Value 'Assessor Initials
ty = ws1112.Range("D7").Value 'Call Type
an = ws1112.Range("D2").Value 'Agreement Number
ss = ws1112.Range("D8").Value 'Sitel Score
si = ws1112.Range("E1").Value & FileYear & "\" & FileMonth & "\" & AgentName & "\" 'Sitel QA Folder
sour = ws1112.Range("A4").Value 'Sitel as Source
Set wb = Workbooks.Open("C:\Users\matthew.varnham\Desktop\QA Improvements\BA Tracker\" & FileYear & "\" & FileMonth & "\" & AgentName & "\" & AgentName & " - " & Agreement & ".xlsm")
Set ws2221 = wb.Sheets("Observation Sheet")
ws2221.Range("B5:C5").Value = s 'Agent Name
ws2221.Range("E5").Value = r 'Call Date
ws2221.Range("F5").Value = cst 'Call Start Time
ws2221.Range("G5").Value = cd 'Call Duration
ws2221.Range("B8:C8").Value = ass 'Assessor Initials
ws2221.Range("B11:C11").Value = ty 'Call Type
ws2221.Range("E8:G8").Value = an 'Agreement Number
ws2221.Range("D4").Value = ss 'Sitel Score
ws2221.Range("G51").Value = si 'Sitel QA Folder
ws2221.Range("C3").Value = sour 'Sitel as Source
End If
Workbooks("SITEL - Inbound Tracker.XLSM").Close SaveChanges:=True
End Sub
You are declaring the variable folderPathWithName twice - once inside in the If block, and then within the 'ElseIf` block.
Just delete the line Dim folderPathWithName As String from within the ElseIf block, and move the line Dim folderPathWithName As String from within the If block to be with all of the other variable declarations.
I would suggest that you always declare all of your variables at the start of the procedure, rather than when you think that you will need them. This stops this from happening, and also keeps your code tidy.
Regards,
I am using VBA to search a network folder with typically about 4000 .txt files and move the bad ones that contain strings listed in an excel range, to another folder. Remaining good files are zipped and moved/scattered and the .txt's moved to a single folder.
Here is my code that takes many hours to run, probably due to the double looping. Please help me with changing this to run faster/more efficient.
Option Compare Text
Sub SDRFiles()
Dim lastRow As Integer
Dim Fldr As Object
Dim BaseFldr As String
Dim sdrDNU As String
Dim sdrDateFldr As String
Dim fDate
Dim FSO As Object
Dim FirstTwo As String
Dim NineTen As String
Dim Lead As String
Dim BadFile As Integer
Dim sdrFile As String
Dim fldExists As String
'Process SDR files. Move files off landing zone to working folder, pull out and store bad files,
'zip good files and move to each owner's folder, save good txt in Data Czar's folder.
'Landing zone
BaseFldr = "\\nasgw013pn\hedis_prod\SDR FILES"
'new SDR folder for files
fDate = Format(Date, "mmddyyyy")
'Processing fldr
sdrDateFldr = BaseFldr & "\" & fDate & "_" & shControl.cboMonth.Value & theCycle
fldExists = Dir(sdrDateFldr)
If fldExists = "" Then
MkDir sdrDateFldr
End If
'Move all files from landing zone to processing folder
Set FSO = CreateObject("scripting.filesystemobject")
extn = "\*.txt"
FSO.MoveFile Source:=BaseFldr & extn, Destination:=sdrDateFldr & "\"
'Do Not Use sub folder for bad files
sdrDNU = sdrDateFldr & "\DNU"
fldExists = Dir(sdrDNU)
If fldExists = "" Then
MkDir sdrDNU
End If
'Good Text File destination
TextFileFldr = fDate & "_" & shControl.cboMonth.Value & theCycle & "_txt"
TextFileDest = sdrDateFldr & "\" & TextFileFldr
fldExists = Dir(TextFileDest)
If fldExists = "" Then
MkDir TextFileDest
End If
'Bottom of bad file strings
lastRow = shSDR.Range("A" & Rows.Count).End(xlUp).Row
Set xFolder = FSO.GetFolder(sdrDateFldr)
'loop thru folder
For Each xFile In xFolder.Files 'About 4000 files. can vary
Fname = xFile.Name
FirstTwo = Left(Fname, 2)
NineTen = Mid(Fname, 9, 2)
Lead = Mid(Fname, 16, 2)
'range with list of bad strings
For Each Item In shSDR.Range("A2:A" & lastRow) 'about 10 strings. can vary
'Hold file from 1st loop and test. If bad file, move to Do Not Use (DNU) folder
If InStr(Fname, Item) > 0 Or _
(InStr(Fname, "PWOEY") > 0 And FirstTwo <> "OH") Or _
(InStr(Fname, "HNARST") > 0 And FirstTwo <> NineTen) Or _
(InStr(Fname, "FTANDHEIPANE") > 0 And FirstTwo <> Lead) Then
'bad file - move to DNU Folder
Name sdrDateFldr & "\" & Fname As sdrDNU & "\" & Fname
'Bad file indentified
BadFile = 1
'exit this loop if matched and get next file
Exit For
End If
Next Item
If BadFile = 0 Then
'Good file - zip it and move each txt file to same folder
Call Zipp(sdrDateFldr & "\" & Replace(Fname, "txt", "zip"), sdrDateFldr & "\" & Fname)
‘move good zipped file to its own specific folder – NY folder, FL folder TX folder etc.
Call MoveIt(sdrDateFldr & "\" & Replace(Fname, "txt", "zip"), Replace(Fname, "txt", "zip"))
End If
BadFile = 0
Next xFile
End Sub
'says function but it really a sub
Public Function Zipp(ZipName, FileToZip)
'Called by all modules to create a Zip File
‘Dim FSO As Object
Dim oApp As Object
If Len(Dir(ZipName)) > 0 Then Kill (ZipName)
If Dir(ZipName) = "" Then
Open ZipName For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End If
dFile = Dir(FileToZip)
On Error Resume Next
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(CVar(ZipName)).CopyHere CVar(FileToZip)
DoEvents
'====HELP!!! ================Please help me with the following. It hangs sporadically, sometimes at
'============================file 200 or may the 1500th file. I have to esc esc and continue.
'============================For 10 to 20 files it seems to run fine
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(CVar(ZipName)).Items.Count = 1
Application.Wait (Now + TimeValue("0:00:06"))
DoEvents
Loop
'=============================================================================
'=============================================================================
'USED ONLY BY Sub SDRFiles()
'THIS PART OF ZIPP SAVES THE .TXT FILE TO DATA CZAR'S FOLDER
'SDR Processing - Move text file
If SDR = "Y" And Len(Dir(FileToZip)) > 0 Then
SetAttr FileToZip, vbNormal
Name FileToZip As TextFileDest & "\" & dFile
End If
Set oApp = Nothing
‘Set FSO = Nothing
End Function
Sub MoveIt(PathZip, ZipFileName)
Dim rootPlusSubFolder As String
Dim NasState As Range
Dim NasLocation As String
Dim FSO As Object
'MOVE ZIPP FILES TO FOLDERS
'MOVE FILES TO IMP FOLDER - find state in extract name and MOVE file to that folder
'Bottom of state list
botRow = shNasMoves.Cells(shNasMoves.Rows.Count, 7).End(xlUp).Row
'Bottom of list of import folder names
NasBot = Sheets("NASMoves").Cells(Rows.Count, "A").End(xlUp).Address
'Look up state to get import folder path
Application.FindFormat.Clear
Set NasState = shNasMoves.Range("A1:" & NasBot).Find(What:=Left(ZipFileName, 2))
'if state found, get folder location URL
If Not NasState Is Nothing Then
NasLocation = NasState.Offset(0, 1).Value
'current month for sub folder file name
CurMonthFolder = "CS_" & theMo & "_" & theCycle & "\"
'Combined destination folder and sub folder name
rootPlusSubFolder = NasLocation & CurMonthFolder
Set FSO = CreateObject("scripting.filesystemobject")
'if CS Import SUB folder doesn't exist, create it - sometimes DIR sometimes FSO
If Not FSO.FolderExists(rootPlusSubFolder) Then
FSO.CreateFolder (rootPlusSubFolder)
End If
'Final dest Fldr
If Not FSO.FolderExists(rootPlusSubFolder & "\" & "SDR") Then
FSO.CreateFolder (rootPlusSubFolder & "\" & "SDR")
End If
'try to stop pop up
With Application
.EnableEvents = False
.DisplayAlerts = False
End With
'Debug.Print rootPlusSubFolder & "SDR"
On Error Resume Next
'move file from Root to destination folder/sub folder
FSO.MoveFile PathZip, rootPlusSubFolder & "SDR\" & ZipFileName
With Application
.EnableEvents = True
.DisplayAlerts = True
End With
End If
End Sub
What i have:
File Names of .zip files in a column
.zip files in a folder (folder path is stored in a cell)
.zip files all have different names (given by the list in a column)
.zip files all have the "same" content (null.shp, null.dbf, null.shx, ..)
A working "snippedtogether"-code (but static so it only works with one specific file):
Sub Unzip()
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Fname = Tabelle1.Range("A7").Value & "testzip.zip" 'Folder Path and Filename of ONE file. Needs to be changed for loop
If Fname = False Then
'Do nothing
Else
'Destination folder
DefPath = Tabelle1.Range("A7").Value 'Folder Path
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
FileNameFolder = DefPath
'Extract the files into the Destination folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).Items
'Rename the files (newfilename was for a testloop)
strFile = Dir(DefPath & "*.shp")
Name DefPath & strFile As DefPath & newfilename & ".shp"
'Rename the files (null.cpg will be renamed into test.cpg)
strFile = Dir(DefPath & "*.cpg")
Name DefPath & strFile As DefPath & "test.cpg"
strFile = Dir(DefPath & "*.dbf")
Name DefPath & strFile As DefPath & "test.dbf"
strFile = Dir(DefPath & "*.kml")
Name DefPath & strFile As DefPath & "test.kml"
strFile = Dir(DefPath & "*.prj")
Name DefPath & strFile As DefPath & "test.prj"
strFile = Dir(DefPath & "*.shx")
Name DefPath & strFile As DefPath & "test.shx"
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
End Sub
What I need:
edit:
Column L in Excel contains the .zip filenames: abc.zip, def.zip, ghi.zip, jkl.zip, mno.zip.
Folder C:/Temp/ contains: abc.zip, def.zip, ghi.zip, jkl.zip, mno.zip.
The files need to be unziped. And all these zip files have content named all the same: null.shp, null.dbf, null.shx, null.cpg, null.kml, null.prf.
So the content needs to be renamed so they match their .zip-filename/cellvalue. --> abc.shp, abc.shx, abc.kml, ... --> def.shp, def.shx, def.kml, ... most likely immediately after unzipped before they get overwritten by next .zip file^^
-edit end
Thought about a loop that runs through the column where .zip filenames are stored and throw back its values. Using the values to rename the just unzipped file(s).
Was messing around with For-loops; For example a partially working one:
Sub UnzipAndRename()
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim rCell As Range
Dim rRng As Range
Set rRng = Range("L3:L5")
For Each rCell In rRng.Cells
newfilename = rCell.Value
Fname = Tabelle1.Range("A7").Value & rCell.Value
Next rCell
If Fname = False Then
'Do nothing
Else
'Destination folder
DefPath = Tabelle1.Range("A7").Value
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
FileNameFolder = DefPath
' 'Delete all the files in the folder DefPath first if you want
' On Error Resume Next
' Kill DefPath & "*.*"
' On Error GoTo 0
'Extract the files into the Destination folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).Items
'MsgBox "You find the files here: " & FileNameFolder
'Rename the extracted files:
' Get first and only file
strFile = Dir(DefPath & "*.shp")
' Move and rename
Name DefPath & strFile As DefPath & newfilename & ".shp"
' Get first and only file
strFile = Dir(DefPath & "*.cpg")
' Move and rename
Name DefPath & strFile As DefPath & newfilename & ".cpg"
' Get first and only file
strFile = Dir(DefPath & "*.dbf")
' Move and rename
Name DefPath & strFile As DefPath & newfilename & ".dbf"
' Get first and only file
strFile = Dir(DefPath & "*.kml")
' Move and rename
Name DefPath & strFile As DefPath & newfilename & ".kml"
' Get first and only file
strFile = Dir(DefPath & "*.prj")
' Move and rename
Name DefPath & strFile As DefPath & newfilename & ".prj"
' Get first and only file
strFile = Dir(DefPath & "*.shx")
' Move and rename
Name DefPath & strFile As DefPath & newfilename & ".shx"
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
End Sub
Its partially working. But it does the job for only one file and ignores the others. On another attempt (with no error message) it just copied all files into the same folder. Wheres the mistake and is this a good solution or are there better ways to do this?
This was taken from here: Excel VBA - read .txt from .zip files and converted.
Sub GetData()
Dim iRow As Integer 'row counter
Dim iCol As Integer 'column counter
Dim savePath As String 'place to save the extracted files
iRow = 1 'start at first row
iCol = 1 'start at frist column
'set the save path to the temp folder
savePath = Environ("TEMP")
Do While ActiveSheet.Cells(iRow, iCol).Value <> ""
UnzipFile savePath, ActiveSheet.Cells(iRow, iCol).Value
iRow = iRow + 1
Loop
End Sub
Sub UnzipFile(savePath As String, zipName As String)
Dim oApp As Shell
Dim strZipFile As String
Dim strFile As String
'get a shell object
Set oApp = CreateObject("Shell.Application")
'check to see if the zip contains items
If oApp.Namespace(zipName).Items.Count > 0 Then
Dim i As Integer
'loop through all the items in the zip file
For i = 0 To oApp.Namespace(zipName).Items.Count - 1
'save the files to the new location
oApp.Namespace(savePath).CopyHere oApp.Namespace(zipName).Items.Item(i)
Dim extensionTxt As String
'get the Zip file name
strZipFile = oApp.Namespace(zipName).Items.Item(i).Parent
'get the unzipped file name
strFile = oApp.Namespace(zipName).Items.Item(i)
'assumes all extensions are 3 chars long
extensionTxt = Right(strFile, 4)
Name savePath & "\" & strFile As savePath & "\" & Replace(strZipFile, ".zip", extensionTxt)
Next i
End If
'free memory
Set oApp = Nothing
End Sub