how to load a sectioned CSV file to an excel sheet? - vba
CSV file:
#3GMACRO,,,,,,,,,,,,,,
,,,,,,,,,,,,,,
IMSI,IMEI,Date,Time,UMTS MACRO-UARFCNDL,UMTS MACRO-PrimaryScramblingCode,UMTS MACRO-CPICHTxPower,UMTS MACRO-PLMNCellId,UMTS MACRO- RNCId,UMTS MACRO-MCC,UMTS MACRO-MNC,UMTS MACRO - LAC,UMTS MACRO - RAC,UMTS MACRO - MaxUETxPower,UMTS MACRO - MeasuredRSCP
2.6275E+14,3.57539E+14,20100107,160000,10662,11,-99,268435456,0,0,0,1,0,0,-74
,,,,,,,,,,,,,,
#3GFEMTO,,,,,,,,,,,,,,
,,,,,,,,,,,,,,
IMSI,IMEI,Date,Time,UMTS FEMTOS-UARFCNDL,UMTS FEMTOS-PrimaryScramblingCode,UMTS FEMTOS-CPICHTxPower,UMTS FEMTOS-PLMNCellId,UMTS FEMTOS-RNCId,UMTS FEMTOS-MCC,UMTS FEMTOS-MNC,UMTS FEMTOS-LAC,UMTS FEMTOS-RAC,UMTS FEMTOS-MaxUETxPower,UMTS FEMTOS- MeasuredRSCP
2.6275E+14,3.57539E+14,20100107,160000,10687,252,-24,61,0,610,3956,486,11,5,-102
,,,,,,,,,,,,,,
#2GMACRO,,,,,,,,,,,,,,
,,,,,,,,,,,,,,
IMSI,IMEI,Date,Time,GSM MACRO_CellID,GSM MACRO-MCC,GSM MACRO-MNC,GSM MACRO-LAC,GSM MACRO-RAC,GSM MACRO-Max permitted UE Tx power (SIB3),GSM MACRO-Measure RSSI,,,,
2.6275E+14,3.57539E+14,20100107,160000,GSM_Cell_Id=1,2,3,4,5,6,7,,,,
i want this csv file to be loaded into an excel sheet as an individual section when I click load only once (ie each section should go to separate worksheet in excel)
CSV file contain Section name , header and data
Below are the section names in CSv file
3GMACRO
3GFEMTO
2GMACRO
Below are the Header names in CSv file
IMSI,IMEI,Date,Time,GSM MACRO_CellID,GSM MACRO-MCC,GSM MACRO-MNC............ etc
3 worksheets should have headers and data after loading CSV file.
Please help me in doing so.
Thanks in advance
hi
this is what the code i tried but its not working perfectly as needed.
Sub loadData()
'Runtime error handling
'On Error Resume Next
'Unprotect the password protected sheet for loading csv data
ActiveSheet.Unprotect Password:=pass
'Variable declaration
Dim strFilePath As String, strFilename As String, strFullPath As String
Dim lngCounter As Long
Dim oConn As Object, oRS As Object, oFSObj As Object
'Get a text file name
strFullPath = Application.GetOpenFilename("Text Files (*.csv),*.csv", , "Please select text file...")
'MsgBox "stringfullpath" & strFullPath
If strFullPath = "False" Then Exit Sub 'User pressed Cancel on the open file dialog
'This gives us a full path name e.g. C:tempfolderfile.txt
'We need to split this into path and file name
Set oFSObj = CreateObject("SCRIPTING.FILESYSTEMOBJECT")
strFilePath = oFSObj.GetFile(strFullPath).ParentFolder.Path
strFilename = oFSObj.GetFile(strFullPath).Name
'Open an ADO connection to the folder specified
Set oConn = CreateObject("ADODB.CONNECTION")
oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strFilePath & ";" & _
"Extended Properties=""text;HDR=Yes;FMT=Delimited"""
Set oRS = CreateObject("ADODB.RECORDSET")
'Now actually open the text file and import into Excel
'oRS.Open "SELECT * FROM " & strFilename & " , oConn"
oRS.Open "SELECT * FROM " & strFilename, oConn
While Not oRS.EOF
Sheets("Neighbour3GMacro").Range("A3").CopyFromRecordset oRS
'Sheets.Add Type:=Application.GetOpenFilename & " *.csv"
Sheets("Neighbour3GFemto").Range("A2").CopyFromRecordset oRS
Sheets("Neighbour2GMacro").Range("A2").CopyFromRecordset oRS
Wend
oRS.Close
oConn.Close
End Sub
You can use the Split function to get an array and use this array to fill a Row. Here is a simple solution.
You will need to change Sheet1, Sheet2, Sheet3 to your worksheet-names and might want to add functionality to ignore header lines. If you have a fix ColumnCount you can also replace the Ubound function with an integer variable.
Sub loadData2()
Dim strFullPath As String
Dim oFSOBj As Object 'Scripting.FileSystemObject'
Dim oFileStream As Object 'Scripting.TextStream'
Dim targetSheet As Worksheet
Dim iRow As Long
Dim startRow As Long
Dim startColumn As Integer
Dim line As String
'Please insert Error Handling etc.'
'Get a text file name '
strFullPath = Application.GetOpenFilename("Text Files (*.csv),*.csv", , "Please select text file...")
If strFullPath = "False" Then Exit Sub 'User pressed Cancel on the open file dialog'
Set oFSOBj = CreateObject("SCRIPTING.FILESYSTEMOBJECT")
Set oFileStream = oFSOBj.GetFile(strFullPath).OpenAsTextStream(ForReading)
Set targetSheet = Sheet1
iRow = 0
startRow = 3
startColumn = 1
While (Not oFileStream.AtEndOfStream)
line = oFileStream.ReadLine
If (Left(line, 1) = "#") Then
iRow = 0
If (Left(line, 8) = "#3GMACRO") Then Set targetSheet = Sheet1
If (Left(line, 8) = "#3GFEMTO") Then Set targetSheet = Sheet2
If (Left(line, 8) = "#2GMACRO") Then Set targetSheet = Sheet3
ElseIf Trim(line) <> vbNullString Then 'Else Block: line has content'
csline = Split(line, ",")
targetSheet.Range(targetSheet.Cells(startRow + iRow, startColumn), targetSheet.Cells(startRow + iRow, startColumn + UBound(csline))).Value2 = csline
iRow = iRow + 1
End If
Wend
oFileStream.Close
Set oFileStream = Nothing
Set oFSOBj = Nothing
End Sub
Related
How to add FileSytemObject to my VBA for creating text flat files in Unicode?
I've managed to piece together this VBA which takes data from excel and turns it into .txt flat file. It works exactly as I need, but I would like to alter it so that the end result is saved as Unicode as opposed to ANSI. I've done some reading and the answer I keep coming back to is to use FileSystemObject. I found a VBA on here that does the job perfectly, but I can't for the life of me work out how to incorporate it into my existing code. Any chance someone could throw me some pointers? This is my current code: ' Defines everything first. So, from B2, across and down. LastRow = Sheets("Pricing").Range("B" & Rows.Count).End(xlUp).Row LastColumn = Sheets("Pricing").Cells(2, Columns.Count).End(xlToLeft).Column ' File name, path to save to and delimiter. file = Sheets("Pricing").TextBox1 & ".txt" If TextBox1.Value = "" Then MsgBox "What we calling it genius?", vbQuestion If TextBox1.Value = "" Then Exit Sub Path = "C:\Users\me.me\Desktop\Files\" Delimeter = "|" ' The magic bit. myFileName = Path & file FN = FreeFile Open myFileName For Output As #FN For Row = 2 To LastRow For Column = 2 To LastColumn If Column = 2 Then Record = Trim(Cells(Row, Column)) Else Record = Record & Delimeter & Trim(Cells(Row, Column)) Next Column Print #FN, Record Next Row Close #FN MsgBox "BOOM! LOOKIT ---> " & myFileName ' Opens the finished file. Dim fso As Object Dim sfile As String Set fso = CreateObject("shell.application") sfile = "C:\Users\me.me\Desktop\Files\" & Sheets("Pricing").TextBox1 & ".txt" fso.Open (sfile) And this is what I've been trying to incorporate (HUGE thanks to MarkJ for posting this on another question): Dim fso As Object, MyFile As Object Set fso = CreateObject("Scripting.FileSystemObject") Set MyFile = fso.CreateTextFile("c:\testfile.txt", False,True) 'Unicode=True' MyFile.WriteLine("This is a test.") MyFile.Close I just can't get it to work.
Please, test the next code. You did not answer my clarification question, but it works using the above comment assumptions. It take the file name, from an activeX text box situated on the sheet to be processed. The code should be faster than yours for big ranges, avoiding to iterate between all cells: Sub SaveAsUnicode() Dim shP As Worksheet, iRow As Long, Record As String, Delimeter As String Dim file As String, myFileName As String, path As String, txtB As MSForms.TextBox Dim rng As Range, lastCell As Range, arr, arrRow Dim fso As Object, MyFile As Object, shApp As Object Set shP = Worksheets("Pricinig") Set txtB = shP.OLEObjects("TextBox1").Object 'it sets an activeX sheet text box file = txtB.Text & ".txt" If txtB.value = "" Then MsgBox "What we calling it genius?", vbQuestion: Exit Sub Set lastCell = shP.cells.SpecialCells(xlCellTypeLastCell) 'last cell of the sheet Set rng = shP.Range("A2", lastCell) 'create the range to be processed arr = rng.value 'put the range in an array path = "C:\Users\me.me\Desktop\Files\" 'take care to adjust the path! myFileName = path & file Delimeter = "|" Set fso = CreateObject("Scripting.FileSystemObject") Set MyFile = fso.CreateTextFile(myFileName, False, True) 'open the file to write Unicode: For iRow = 1 To UBound(arr) 'itereate between the array rows arrRow = Application.Index(arr, iRow, 0) 'make a slice of the currrent arrray row Record = Join(arrRow, Delimeter) 'join the iD obtained array, using the set Delimiter MyFile.WriteLine (Record) 'write the row in the Unicode file Next iRow MyFile.Close 'close the file 'open the obtained Unicode file: Set shApp = CreateObject("shell.application") shApp.Open (myFileName) End Sub I tested the above code on a sheet using characters not supported in ANSI and it works as expected. Please, send some feedback after testing it, or if my assumptions after reading your question are not correct...
#FaneDuru, this is what I ended up putting together, it's working great for me. Thanks again for all of your help. Private Sub FlatButton_Click() 'Does all the setup stuff. Dim fso As Object, MyFile As Object Dim MyFileName As String Dim txtB As MSForms.TextBox Set shP = Worksheets("Pricing") Set txtB = shP.OLEObjects("TextBox1").Object file = txtB.Text & ".txt" If txtB.Value = "" Then MsgBox "What we calling it?", vbQuestion: Exit Sub ' Defines the range. So, from B2, across and down. LastRow = Sheets("Pricing").Range("B" & Rows.Count).End(xlUp).Row LastColumn = Sheets("Pricing").Cells(2, Columns.Count).End(xlToLeft).Column 'File details. path = "C:\Users\me.me\Blah\Blah\" MyFileName = path & file Delimeter = "|" ' The magic bit. Set fso = CreateObject("Scripting.FileSystemObject") Set MyFile = fso.CreateTextFile(MyFileName, False, True) '<==== This defines the Unicode bit. For Row = 2 To LastRow For Column = 2 To LastColumn If Column = 2 Then Record = Trim(Cells(Row, Column)) Else Record = Record & Delimeter & Trim(Cells(Row, Column)) Next Column MyFile.WriteLine (Record) Next Row MyFile.Close MsgBox "BOOM! ---> " & MyFileName 'Option to open the finished product. If ActiveSheet.CheckBox2.Value = True Then Set shApp = CreateObject("shell.application") shApp.Open (MyFileName) End If End Sub
vba loop through files in folder and copy names if multiple conditions are met/not met
I would like to loop through a folder and copy all the names of the excelfiles which does not contain "string1" in A6, "string2" in B6, "string3" in C6, "string4" in D6. Note all the conditions should be true (a AND statement). The cells which should be tested are located in sheet 3, which is called "ProjectOperation". The following code copy pase the filenames of all excel in a specific folder, however I have a hard time implementing the conditions. Please help. Option Explicit Sub SubDirList() 'Excel VBA process to loop through directories listing files Dim sname As Variant Dim sfil(1 To 1) As String sfil(1) = "C:\Users\test" 'Change this path to suit. For Each sname In sfil() SelectFiles sname Next sname End Sub Private Sub SelectFiles(sPath) 'Excel VBA to show file path name. Dim Folder As Object Dim file As Object Dim fldr Dim oFSO As Object Dim i As Integer 'For Each file In Folder ' If checknameExistens(Folder.Files) Then Set oFSO = CreateObject("Scripting.FileSystemObject") Set Folder = oFSO.GetFolder(sPath) i = 1 For Each fldr In Folder.SubFolders SelectFiles fldr.Path Next fldr For Each file In Folder.Files 'If checknameExistens(Folder.Files) Then Range("A6536").End(xlUp)(2).Value = file i = i + 1 Next file Set oFSO = Nothing End Sub The original code is from the following link: http://www.thesmallman.com/list-files-in-subdirectory/
First of all I changed the code which retrieves the files because it collects all file regardless if it is a excel file or not. I also changed it to a function which gives all the files back in a collection Function SelectFiles(ByVal sPath As String, ByVal pattern As String) As Collection Dim Folder As Object Dim file As Object Dim fldr Dim oFSO As Object Dim coll As New Collection Set oFSO = CreateObject("Scripting.FileSystemObject") Set Folder = oFSO.GetFolder(sPath) For Each fldr In Folder.SubFolders SelectFiles fldr.path, pattern Next fldr For Each file In Folder.Files If file.Name Like pattern Then coll.Add file End If Next file Set SelectFiles = coll End Function Then I used the following function to retrieve the contents of the files which you can find here resp. here Private Function GetValue(path, file, sheet, ref) ' Retrieves a value from a closed workbook Dim arg As String ' Make sure the file exists If Right(path, 1) <> "\" Then path = path & "\" If Dir(path & file) = "" Then GetValue = "File Not Found" Exit Function End If ' Create the argument arg = "'" & path & "[" & file & "]" & sheet & "'!" & _ Range(ref).Range("A1").Address(, , xlR1C1) ' Execute an XLM macro GetValue = ExecuteExcel4Macro(arg) If IsError(GetValue) Then GetValue = "" End Function And this is the final result Sub TestList() Const SH_NAME = "ProjectOperation" Dim sname As Variant Dim coll As Collection Dim s1 As String Dim s2 As String Dim s3 As String Dim s4 As String Dim i As Long sname = "...." 'Change this path to suit. Set coll = SelectFiles(sname, "*.xls*") For i = 1 To coll.Count s1 = GetValue(coll.Item(i).parentfolder, coll.Item(i).Name, SH_NAME, "A6") s2 = GetValue(coll.Item(i).parentfolder, coll.Item(i).Name, SH_NAME, "B6") s3 = GetValue(coll.Item(i).parentfolder, coll.Item(i).Name, SH_NAME, "C6") s4 = GetValue(coll.Item(i).parentfolder, coll.Item(i).Name, SH_NAME, "D6") If s1 = "string1" And s2 = "string2" And s3 = "string3" And s4 = "string4" Then Debug.Print coll.Item(i).path End If Next End Sub
I worked with your existing code and have just added an If statement inside your loop (as well as a couple of declarations of new variables). Because you are now working with two files you need to properly reference the workbook and sheet whenever you refer to a range. '... Dim wb As Workbook, ws As Worksheet Application.ScreenUpdating = False For Each file In Folder.Files Set wb = Workbooks.Open(file) Set ws = wb.Sheets("ProjectOperation") If ws.Range("A6").Value = "string1" And ws.Range("B6").Value = "string2" And _ ws.Range("c6").Value = "string3" And ws.Range("D6").Value = "string4" Then ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp)(2).Value = file 'workbook/sheet references may need changing i = i + 1 End If wb.Close False Next file Application.ScreenUpdating = True '...
Looking to Loop Excel VBA Macro through Multiple Worksheets?
Looking to loop the following code through (about) 125 worksheets in an Excel workbook and pull the listed cell values into one database entry log on the 'Database' worksheet'. Right now it is only pulling from one of the tabs . (PO VT-0189). Wondering how to correct. Private Sub PopulateOrderInfo() Dim OrderDate As String, PONumber As String, Vendor As String, ShipTo As String, SKU As String Dim R As Long, LastSKURow As Long, NextDBRow As Long, OFrm As Worksheet, DB As Worksheet For Each OFrm In ActiveWorkbook.Worksheets Set OFrm = Worksheets("PO VT-0189") Set DB = Worksheets("Database") OrderDate = OFrm.Range("N4") PONumber = OFrm.Range("N3") Vendor = OFrm.Range("A13") ShipTo = OFrm.Range("I13") POTotal = OFrm.Range("P43") LastSKURow = OFrm.Range("A38").End(xlUp).Row For R = 21 To LastSKURow SKU = OFrm.Range("A" & R).Value SKUDesc = OFrm.Range("D" & R).Value SKUQty = OFrm.Range("K" & R).Value Lntotal = OFrm.Range("M" & R).Value NextDBRow = DB.Cells(DB.Rows.Count, "A").End(xlUp).Row + 1 DB.Range("A" & NextDBRow).Value = OrderDate DB.Range("B" & NextDBRow).Value = PONumber DB.Range("C" & NextDBRow).Value = Vendor DB.Range("D" & NextDBRow).Value = ShipTo DB.Range("E" & NextDBRow).Value = SKU DB.Range("F" & NextDBRow).Value = SKUDesc DB.Range("G" & NextDBRow).Value = SKUQty DB.Range("H" & NextDBRow).Value = Lntotal DB.Range("I" & NextDBRow).Value = POTotal Next R Next OFrm End Sub
I think you can also shorten your code by avoiding the loop and most of the variables seem unnecessary to me. Private Sub PopulateOrderInfo() Dim R As Long, LastSKURow As Long, NextDBRow As Long, OFrm As Worksheet, DB As Worksheet Set DB = Worksheets("Database") For Each OFrm In ActiveWorkbook.Worksheets If OFrm.Name <> DB.Name Then LastSKURow = OFrm.Range("A38").End(xlUp).Row R = LastSKURow - 21 + 1 NextDBRow = DB.Cells(DB.Rows.Count, "A").End(xlUp).Row + 1 DB.Range("A" & NextDBRow).Resize(R).Value = OFrm.Range("N4") DB.Range("B" & NextDBRow).Resize(R).Value = OFrm.Range("N3") DB.Range("C" & NextDBRow).Resize(R).Value = OFrm.Range("A13") DB.Range("D" & NextDBRow).Resize(R).Value = OFrm.Range("I13") DB.Range("E" & NextDBRow).Resize(R).Value = OFrm.Range("A21").Resize(R).Value DB.Range("F" & NextDBRow).Resize(R).Value = OFrm.Range("D21").Resize(R).Value DB.Range("G" & NextDBRow).Resize(R).Value = OFrm.Range("K21").Resize(R).Value DB.Range("H" & NextDBRow).Resize(R).Value = OFrm.Range("M21").Resize(R).Value DB.Range("I" & NextDBRow).Resize(R).Value = OFrm.Range("P43") End If Next OFrm End Sub
Use a for loop and WorkSheets collection like: For I = 1 to worksheets.count if worksheets(i).name <> "Database" then Add your code here end if Next i This loops through every worksheet in your workbook and does what ever you need to all worksheets except the Database.
Using a for each... loop For Each ws In wb.Worksheets If ws.name = "Database" Then 'Leave blank to just skip database. Code here if you want something special on database. OR statements can be used to exclude additional sheets Else 'Code here End If Next
I think you described the issue fairly well. Just to confirm, you want to loop through all worksheets in one single workbook, right. Try the script below. Feedback if you have additional questions, concerns, etc. Thanks. Sub ImportAll() Dim blnHasFieldNames As Boolean, blnEXCEL As Boolean, blnReadOnly As Boolean Dim lngCount As Long Dim objExcel As Object, objWorkbook As Object Dim colWorksheets As Collection Dim strPathFile as String, strTable as String Dim strPassword As String ' Establish an EXCEL application object On Error Resume Next Set objExcel = GetObject(, "Excel.Application") If Err.Number <> 0 Then Set objExcel = CreateObject("Excel.Application") blnEXCEL = True End If Err.Clear On Error GoTo 0 ' Change this next line to True if the first row in EXCEL worksheet ' has field names blnHasFieldNames = False ' Replace C:\Filename.xls with the actual path and filename strPathFile = "C:\Filename.xls" ' Replace tablename with the real name of the table into which ' the data are to be imported strTable = "tablename" ' Replace passwordtext with the real password; ' if there is no password, replace it with vbNullString constant ' (e.g., strPassword = vbNullString) strPassword = "passwordtext" blnReadOnly = True ' open EXCEL file in read-only mode ' Open the EXCEL file and read the worksheet names into a collection Set colWorksheets = New Collection Set objWorkbook = objExcel.Workbooks.Open(strPathFile, , blnReadOnly, , _ strPassword) For lngCount = 1 To objWorkbook.Worksheets.Count colWorksheets.Add objWorkbook.Worksheets(lngCount).Name Next lngCount ' Close the EXCEL file without saving the file, and clean up the EXCEL objects objWorkbook.Close False Set objWorkbook = Nothing If blnEXCEL = True Then objExcel.Quit Set objExcel = Nothing ' Import the data from each worksheet into the table For lngCount = colWorksheets.Count To 1 Step -1 DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _ strTable, strPathFile, blnHasFieldNames, colWorksheets(lngCount) & "$" Next lngCount ' Delete the collection Set colWorksheets = Nothing ' Uncomment out the next code step if you want to delete the ' EXCEL file after it's been imported ' Kill strPathFile End Sub
Getting the directory of the file and send as attachment in outlook
I have this code that gets the filenames on the selected directories. Sub browsefile() Dim file As Variant Dim i As Integer Dim lRow As Long Set main = ThisWorkbook.Sheets("Main") file = Application.GetOpenFilename("All Files, *.*", , "Select File", , True) For i = 1 To UBound(file) lRow = Cells(Rows.Count, 15).End(xlUp).Row lRow = lRow + 1 ThisWorkbook.Sheets("Main").Range("O" & lRow).Value = GetFileName(CStr(file(i))) Next i End Sub Function GetFileName(filespec As String) Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") GetFileName = fso.GetFileName(filespec) End Function Once I've selected the files, I have to put it in Column O. I have tried using .FullName but is not applicable in this area or maybe I've just misused it. Then later this will be send as attached file in an email in outlook. By the way, I've got some of its code here. Any help?
In Outlook include attachments with Attachments.Add Private Sub browsefile_Att() ' Multiselect = False so file is not an array ' Dim file As Variant Dim file As String Dim lRow As Long Dim main As Worksheet Dim olOlk As Object Dim olNewmail As Object Set main = ThisWorkbook.Sheets("Main") ' Multiselect = False so file is not an array file = Application.GetOpenFilename("All Files, *.*", , "Select File", , False) lRow = Cells(Rows.Count, 15).End(xlUp).Row lRow = lRow + 1 ThisWorkbook.Sheets("Main").Range("O" & lRow).Value = file Set olOlk = CreateObject("Outlook.Application") Set olNewmail = olOlk.CreateItem(olMailItem) olNewmail.Attachments.Add file olNewmail.Display ExitRoutine: Set olNewmail = Nothing Set olOlk = Nothing End Sub
I assume you are trying to obtain the full path to the file that you have selected. Application.GetOpenFilename already returns you that and hence, there is no need to reprocess your file with GetFileName function? Changing ThisWorkbook.Sheets("Main").Range("O" & lRow).Value = GetFileName(CStr(file(i))) To ThisWorkbook.Sheets("Main").Range("O" & lRow).Value = CStr(file(i)) should work assuming i have understood your question correctly. Hope this helps!
Run time error Library not registered while opening a .doc file
I created a macro in excel vba to process a list of file that I need to copy from a "source path" to a "target path". When copied I also need to remove the protection of the .doc file. Everything is working perfectly fine but only on my station. When I try it on two others stations I get the following error message: "Run time error '2147319779 (8002801d)' Automation error Library not registered" Here's what I already checked: I've checked for the VBA references in Excel and Word and they are the same. From what I can found on other forums it could be some hexkeys problem, but I'm so afraid of playing into this, and also the solution that was proposed wasn't working (I couldn't find the appropriate reg key on the problem station). I also tried adding some delay, but still no luck Here's my code below Sub copy_file_and_unprotect() Dim ws As Worksheet Dim wb As Workbook Dim original_name As String Dim copied_name As String Dim WdApp As Object Dim source_path As String Dim target_path As String Dim pwd As String Set wb = ThisWorkbook Set ws = wb.Worksheets("Liste de vérification") 'where the original folder is stored target_path = ws.Cells(1, 6) & "\Sections de devis type" Set ws = wb.Worksheets("Nom des divisions") source_path = ws.Cells(4, 5) 'where the file will be copied pwd = "cimaqc123" 'password to unprotect the file Set wb = ThisWorkbook Set ws = wb.Worksheets("Plan de travail") lig = 11 col = 26 Set WdApp = CreateObject("Word.Application") While ws.Cells(lig, col) <> "" 'loop to copy & unprotect a list of file num_sec = ws.Cells(lig, col) nom_sec = ws.Cells(lig, col + 2) file_name = num_sec & " - " & nom_sec & ".doc" 'name of the original file to be copied F = Dir(source_path & "\" & "*.doc") 'loop to search thru the source file for the file "file_name" Do While Len(F) > 0 If F = file_name Then ' original_name = source_path & "\" & F 'path and name of file to be copied copied_name = target_path & "\" & file_name 'path and name of new file to be unlocked later on FileCopy original_name, copied_name 'copying of the file '-----THIS IS WHERE I GET THE ERROR MESSAGE AFTER THE FOLLOWING LINE----- Set WdApp = Documents.Open(copied_name) If Not WdApp.ProtectionType = -1 Then 'unprotect the file WdApp.Unprotect pwd WdApp.Close True Else WdApp.Close True End If GoTo file_copied: End If F = Dir() Loop file_copied: lig = lig + 1 'on passe à la prochaine section de devis Wend End Sub Could anyone share some taughts about this? How can I resolve the error message I get?
With the help from #KenWhite here's the updated code with error resolved Sub copy_file_and_unprotect() Dim ws As Worksheet Dim wb As Workbook Dim original_name As String Dim copied_name As String Dim WdApp As Object Dim WdDoc As Object Dim source_path As String Dim target_path As String Dim pwd As String Set wb = ThisWorkbook Set ws = wb.Worksheets("Liste de vérification") 'where the original folder is stored target_path = ws.Cells(1, 6) & "\Sections de devis type" Set ws = wb.Worksheets("Nom des divisions") source_path = ws.Cells(4, 5) 'where the file will be copied pwd = "cimaqc123" 'password to unprotect the file Set wb = ThisWorkbook Set ws = wb.Worksheets("Plan de travail") lig = 11 col = 26 Set WdApp = CreateObject("Word.Application") While ws.Cells(lig, col) <> "" 'loop to copy & unprotect a list of file num_sec = ws.Cells(lig, col) nom_sec = ws.Cells(lig, col + 2) file_name = num_sec & " - " & nom_sec & ".doc" 'name of the original file to be copied F = Dir(source_path & "\" & "*.doc") 'loop to search thru the source file for the file "file_name" Do While Len(F) > 0 If F = file_name Then ' original_name = source_path & "\" & F 'path and name of file to be copied copied_name = target_path & "\" & file_name 'path and name of new file to be unlocked later on FileCopy original_name, copied_name 'copying of the file '----------------LINE BELOW IS WHERE IT WAS CAUSING PROBLEM ------------------------- Set WdDoc = WdApp.Documents.Open(copied_name) 'line that was add 'Set WdApp = Documents.Open(copied_name) 'line that was removed If Not WdDoc.ProtectionType = -1 Then 'unprotect the file WdDoc.Unprotect pwd 'replaced WdApp by WdDoc WdDoc.Save WdDoc.Close True Else WdDoc.Close True End If GoTo file_copied: End If F = Dir() Loop file_copied: lig = lig + 1 Wend End Sub