Open all files in a folder using list of password

Dear all,

I am a beginner in using macro excel for automation.

I have nearly 100 of excel files with password. I would like to do as follows.

- Step 1: I will choose Input folder contains all excel files.
- Step 2: I will choose Output folder contains all output excel file.
- Step 3: File structure and password are as follows.

File structure Password
PV*.xlsx PV
JP*.xls JP
PIT calculation*01-20*.xlsx 0120
PIT calculation*02-20*.xlsx 0220
PIT calculation*03-20*.xlsx 0320
PIT calculation*04-20*.xlsx 0420
PIT calculation*05-20*.xlsx 0520
PIT calculation*06-20*.xlsx 0620
PIT calculation*07-20*.xlsx 0720
PIT calculation*08-20*.xlsx 0820
PIT calculation*09-20*.xlsx 0920
PIT calculation*10-20*.xlsx 1020
PIT calculation*11-20*.xlsx 1120
PIT calculation*12-20*.xlsx 1220

Step 4: if the input file in .xls, convert it to .xlsx

I have write a code as follows but when I run it, it seems endless run. Please help to correct my code. Thank you.

Sub RemovePasswords()
Dim xlBook As Workbook
Dim InPath As Variant 'Input Folder Path
Dim OutPath As Variant 'Output Folder Path
Dim x1BookName As Variant

    InPath = ThisWorkbook.Sheets("RemovePassword").Range("B2").Value & "\"       'The Input folder, must end with "\"
    OutPath = ThisWorkbook.Sheets("RemovePassword").Range("B3").Value & "\"       'The Output folder , must end with "\"
Const strEditPassword As String = "" 'If no password use ""

'File structure 1 and password 1
Dim strFilename1 As String
Dim strPassword1 As String
    strFilename1 = Dir$(InPath & ThisWorkbook.Sheets("RemovePassword").Range("A8").Value)  'will open xls & xlsx etc
    strPassword1 = ThisWorkbook.Sheets("RemovePassword").Range("B8").Value
    While Len(strFilename1) <> 0
        Application.DisplayAlerts = False
        Set xlBook = Workbooks.Open(Filename:=InPath & strFilename1, _
                                    Password:=strPassword1, _
                                    WriteResPassword:=strEditPassword)
        x1BookName = ActiveWorkbook.Name
        
        xlBook.SaveAs Filename:=OutPath & x1BookName, _
                      Password:="", _
                      WriteResPassword:="", _
                      CreateBackup:=True
        xlBook.Close 0
        Application.DisplayAlerts = True
    Wend

'File structure 2 and password 2 then save as .xlsx

Dim strFilename2 As String
Dim strPassword2 As String
    strFilename2 = Dir$(InPath & ThisWorkbook.Sheets("RemovePassword").Range("A9").Value)  'will open xls & xlsx etc
    strPassword2 = ThisWorkbook.Sheets("RemovePassword").Range("B9").Value
    While Len(strFilename2) <> 0
        Application.DisplayAlerts = False
        Set xlBook = Workbooks.Open(Filename:=InPath & strFilename2, _
                                    Password:=strPassword2, _
                                    WriteResPassword:=strEditPassword)
        x1BookName = ActiveWorkbook.Name
        
        xlBook.SaveAs Filename:=OutPath & Left(x1BookName, Len(x1BookName) - 5) & ".xlsx", _
                        FileFormat:=xlOpenXMLWorkbook, _
                      Password:="", _
                      WriteResPassword:="", _
                      CreateBackup:=True
        xlBook.Close 0
        Application.DisplayAlerts = True
    Wend

'File structure 3 and password 3

Dim strFilename3 As Range
Dim strPassword3 As String
Set FilenameRange = ThisWorkbook.Sheets("RemovePassword").Range("A9:A20")
    
    For Each strFilename3 In FilenameRange 'or For Each strFilename3 In Range("A5", Cells(Rows.Count, 1).End(xlUp))
    strPassword3 = strFilename3.Offset(0, 1).Value
    
        Application.DisplayAlerts = False
    If Not Len(strFilename3) = 0 Then
         Application.DisplayAlerts = False
        Set xlBook = Workbooks.Open(Filename:=InPath & strFilename2, _
                                    Password:=strPassword2, _
                                    WriteResPassword:=strEditPassword)
        x1BookName = ActiveWorkbook.Name
        
        xlBook.SaveAs Filename:=OutPath & x1BookName, _
                      Password:="", _
                      WriteResPassword:="", _
                      CreateBackup:=True
        xlBook.Close 0
        
    End If

    Next strFilename3
    Application.DisplayAlerts = True
End Sub

• As yet stated according to your 'File structure' list only 2 files can be treated so you must first correct this list …
  
  
• On my side the Dir VBA function can not work 'cause of the asian characters in some files names so according to your attachment :
  
  

PHP Code: 

Sub Demo1()
        Dim P, F$, oF As Object, V
    With Sheet1
            P = .[TRANSPOSE(B2:B3&IF(RIGHT(B2:B3,1)<>"\","\",""))]
        With .Range("A8", .[B7].End(xlDown)).Columns
            F = "TRANSPOSE(IF(ISNUMBER(MATCH(" & .Item(1).Address(, , , True) & ",{""#""},0))," & .Item(2).Address(, , , True) & "))"
        End With
    End With
    With CreateObject("Scripting.FileSystemObject")
        If .FolderExists(P(1)) And .FolderExists(P(2)) Then
                Application.DisplayAlerts = False:  Application.ScreenUpdating = False
            For Each oF In .GetFolder(P(1)).Files
                    V = Filter(Evaluate(Replace(F, "#", oF.Name)), False, False)
                If UBound(V) = 0 Then
                    With Workbooks.Open(oF.Path, , , , V(0))
                        .SaveAs P(2) & Left(oF.Name, InStrRev(oF.Name, ".")) & "xlsx", 51, Empty
                        .Close
                    End With
                End If
            Next
                Application.DisplayAlerts = True:  Application.ScreenUpdating = True
        Else
            Beep
        End If
    End With
End Sub 


► Do you like it ? ► ► So thanks to click on bottom left star icon « ★ Add Reputation » ! ◄ ◄

Thanks for the rep' !

So the file name structure is still bad as a ".xlsx" file can not be a ".xlsx " file !

Again, just correct the list and no need to review the code as it well works on my side once the list is correct,
the reason why of my warning about this list …