Excel複数ファイルマクロ - セルA1にファイル名を書き込む

Question

同じブックの特定のセルにブックのファイル名を自動的に書き込む方法はありますか？

1つのフォルダに複数の* .xlsxファイルがあります。各ファイルの名前は異なります（例：file01.xlsx、file02.xlsx、file03.xlsxなど）。 1つは、指定されたフォルダ内で見つかった各.xlsxファイルのファイル名を確認し、b）各ワークブックのA1セルにファイル拡張子なしの対応する名前を書き込んでから、3 ）それを保存します。だから、最後に、file01.xlsxのセルA1は

これはあなたが求めて何になるあなたに

Answer 1

ありがとう...値「FILE01」を持つことになります。

Sub Example() 
    Dim MyPath As String, FilesInPath As String 
    Dim MyFiles() As String, Fnum As Long 
    Dim mybook As Workbook 
    Dim CalcMode As Long 
    Dim sh As Worksheet 
    Dim ErrorYes As Boolean 

    'Fill in the path\folder where the files are 
    MyPath = "C:\Users\Ron\test" 

    'Add a slash at the end if the user forget it 
    If Right(MyPath, 1) <> "\" Then 
     MyPath = MyPath & "\" 
    End If 

    'If there are no Excel files in the folder exit the sub 
    FilesInPath = Dir(MyPath & "*.xl*") 
    If FilesInPath = "" Then 
     MsgBox "No files found" 
     Exit Sub 
    End If 

    'Fill the array(myFiles)with the list of Excel files in the folder 
    Fnum = 0 
    Do While FilesInPath <> "" 
     Fnum = Fnum + 1 
     ReDim Preserve MyFiles(1 To Fnum) 
     MyFiles(Fnum) = FilesInPath 
     FilesInPath = Dir() 
    Loop 

    'Change ScreenUpdating, Calculation and EnableEvents 
    With Application 
     CalcMode = .Calculation 
     .Calculation = xlCalculationManual 
     .ScreenUpdating = False 
     .EnableEvents = False 
    End With 

    'Loop through all files in the array(myFiles) 
    If Fnum > 0 Then 
     For Fnum = LBound(MyFiles) To UBound(MyFiles) 
      Set mybook = Nothing 
      On Error Resume Next 
      Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum)) 
      On Error GoTo 0 

      If Not mybook Is Nothing Then 


       'Change cell value(s) in one worksheet in mybook 
       On Error Resume Next 
       With mybook.Worksheets(1) 
        If .ProtectContents = False Then 
         .Range("A1").Value = "My New Header" 
        Else 
         ErrorYes = True 
        End If 
       End With 


       If Err.Number > 0 Then 
        ErrorYes = True 
        Err.Clear 
        'Close mybook without saving 
        mybook.Close savechanges:=False 
       Else 
        'Save and close mybook 
        mybook.Close savechanges:=True 
       End If 
       On Error GoTo 0 
      Else 
       'Not possible to open the workbook 
       ErrorYes = True 
      End If 

     Next Fnum 
    End If 

    If ErrorYes = True Then 
     MsgBox "There are problems in one or more files, possible problem:" _ 
      & vbNewLine & "protected workbook/sheet or a sheet/range that not exist" 
    End If 

    'Restore ScreenUpdating, Calculation and EnableEvents 
    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
     .Calculation = CalcMode 
    End With 
End Sub 

すべての詳細については、このリンクをクリックしてください。

http://www.rondebruin.nl/win/s3/win010.htm

Answer 2

おかげでみんな。これは私のために働いたコードです：

Sub Example() 
    Dim MyPath As String, FilesInPath As String 
    Dim MyFiles() As String, Fnum As Long 
    Dim mybook As Workbook 
    Dim CalcMode As Long 
    Dim sh As Worksheet 
    Dim ErrorYes As Boolean 

    'Fill in the path\folder where the files are 
    MyPath = "C:" 

    'Add a slash at the end if the user forget it 
    If Right(MyPath, 1) <> "\" Then 
     MyPath = MyPath & "\" 
    End If 

    'If there are no Excel files in the folder exit the sub 
    FilesInPath = Dir(MyPath & "*.xl*") 
    If FilesInPath = "" Then 
     MsgBox "No files found" 
     Exit Sub 
    End If 

    'Fill the array(myFiles)with the list of Excel files in the folder 
    Fnum = 0 
    Do While FilesInPath <> "" 
     Fnum = Fnum + 1 
     ReDim Preserve MyFiles(1 To Fnum) 
     MyFiles(Fnum) = FilesInPath 
     FilesInPath = Dir() 
    Loop 

    'Change ScreenUpdating, Calculation and EnableEvents 
    With Application 
     CalcMode = .Calculation 
     .Calculation = xlCalculationManual 
     .ScreenUpdating = False 
     .EnableEvents = False 
    End With 

    'Loop through all files in the array(myFiles) 
    If Fnum > 0 Then 
     For Fnum = LBound(MyFiles) To UBound(MyFiles) 
      Set mybook = Nothing 
      On Error Resume Next 
      Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum)) 
      On Error GoTo 0 

      If Not mybook Is Nothing Then 


       'Change cell value(s) in one worksheet in mybook 
       On Error Resume Next 
       With mybook.Worksheets(1) 
        If .ProtectContents = False Then 
         .Range("A1").Value = Left(mybook.Name, Len(mybook.Name) - 5) 
        Else 
         ErrorYes = True 
        End If 
       End With 


       If Err.Number > 0 Then 
        ErrorYes = True 
        Err.Clear 
        'Close mybook without saving 
        mybook.Close savechanges:=False 
       Else 
        'Save and close mybook 
        mybook.Close savechanges:=True 
       End If 
       On Error GoTo 0 
      Else 
       'Not possible to open the workbook 
       ErrorYes = True 
      End If 

     Next Fnum 
    End If 

    If ErrorYes = True Then 
     MsgBox "There are problems in one or more files, possible problem:" _ 
      & vbNewLine & "protected workbook/sheet or a sheet/range that not exist" 
    End If 

    'Restore ScreenUpdating, Calculation and EnableEvents 
    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
     .Calculation = CalcMode 
    End With 
End Sub