フォルダ内のファイルをループして日付を追加するタブ

Question

フォルダ内のワークブックのセットに移動し、それぞれの名前に現在の日付のタブを追加しようとしています。

以下のコードは、最初のファイルを開き、タブを正しく追加しますが、ループして残りのファイルを開きません。

Sub LoopThroughFolder() 

Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook 
Set Wb = ThisWorkbook 

MyDir = "C:\Users\u558683\Desktop\QA VBA Project\LoopTabs\" 
MyFile = Dir(MyDir & "*.xlsx") 
ChDir MyDir 


Do While MyFile <> "" 

Workbooks.Open (MyFile) 
    TabName = Format(Date, "mmm-yyyy") 'Change the format as per your requirement 

On Error GoTo AddNew 
Sheets(TabName).Activate 
Exit Sub 

AddNew: 
Sheets.Add , Worksheets(Worksheets.Count) 
ActiveSheet.Name = TabName 

ActiveSheet.Previous.Range("A1:AJ4").Copy Destination:=Range("A1") 
ActiveSheet.Previous.Range("AL1:AN500").Copy Destination:=Range("AK1") 

Loop 


End Sub 

Answer 1

2問題：

1. あなたがあなたの次のファイル名を与えるMyFile = Dir()を逃しました。
2. あなたはExit Subを使用しましたが、これは治療を続けることなくただちにプログラムから抜け出すことになります。

---

固定コード：

Sub LoopThroughFolder() 
Dim MyFile As String, Str As String, MyDir As String 
Dim Tb As Workbook, wB As Workbook 
Set Tb = ThisWorkbook 

MyDir = "C:\Users\u558683\Desktop\QA VBA Project\LoopTabs\" 
MyFile = Dir(MyDir & "*.xlsx") 

Do While MyFile <> vbNullString 
    Set wB = Workbooks.Open(MyDir & MyFile) 
    TabName = Format(Date, "mmm-yyyy") 'Change the format as per your requirement 

    On Error Resume Next 
    wB.Sheets(TabName).Activate 
    If Err.Number > 0 Then 
     'AddNewSheet 
     wB.Sheets.Add , wB.Sheets(wB.Sheets.Count) 
     ActiveSheet.Name = TabName 
     ActiveSheet.Previous.Range("A1:AJ4").Copy Destination:=Range("A1") 
     ActiveSheet.Previous.Range("AL1:AN500").Copy Destination:=Range("AK1") 
     wB.Save 
    Else 
    End If 
    On Error GoTo 0 
    wB.Close False 
    MyFile = Dir() 
Loop 

End Sub