未打开/已关闭的Excel工作簿文件中的链接值

2 回答

• 0

  为什么工作簿必须保持关闭？您可以轻松地将文件夹中所有工作簿中的数据导入到包含所有内容的母版文件中 .

  Sub Basic_Example_1()
      Dim MyPath As String, FilesInPath As String
      Dim MyFiles() As String
      Dim SourceRcount As Long, Fnum As Long
      Dim mybook As Workbook, BaseWks As Worksheet
      Dim sourceRange As Range, destrange As Range
      Dim rnum As Long, CalcMode As Long
  
      '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
  
      'Add a new workbook with one sheet
      Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
      rnum = 1
  
      '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
  
                  On Error Resume Next
  
                  With mybook.Worksheets(1)
                      Set sourceRange = .Range("A1:C1")
                  End With
  
                  If Err.Number > 0 Then
                      Err.Clear
                      Set sourceRange = Nothing
                  Else
                      'if SourceRange use all columns then skip this file
                      If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                          Set sourceRange = Nothing
                      End If
                  End If
                  On Error GoTo 0
  
                  If Not sourceRange Is Nothing Then
  
                      SourceRcount = sourceRange.Rows.Count
  
                      If rnum + SourceRcount >= BaseWks.Rows.Count Then
                          MsgBox "Sorry there are not enough rows in the sheet"
                          BaseWks.Columns.AutoFit
                          mybook.Close savechanges:=False
                          GoTo ExitTheSub
                      Else
  
                          'Copy the file name in column A
                          With sourceRange
                              BaseWks.cells(rnum, "A"). _
                                      Resize(.Rows.Count).Value = MyFiles(Fnum)
                          End With
  
                          'Set the destrange
                          Set destrange = BaseWks.Range("B" & rnum)
  
                          'we copy the values from the sourceRange to the destrange
                          With sourceRange
                              Set destrange = destrange. _
                                              Resize(.Rows.Count, .Columns.Count)
                          End With
                          destrange.Value = sourceRange.Value
  
                          rnum = rnum + SourceRcount
                      End If
                  End If
                  mybook.Close savechanges:=False
              End If
  
          Next Fnum
          BaseWks.Columns.AutoFit
      End If
  
  ExitTheSub:
      'Restore ScreenUpdating, Calculation and EnableEvents
      With Application
          .ScreenUpdating = True
          .EnableEvents = True
          .Calculation = CalcMode
      End With
  End Sub
  

  您可能还想考虑使用下面链接中的AddIn .

  https://www.rondebruin.nl/win/addins/rdbmerge.htm

  

  回复于 2024-05-05T04:24:00+08:00
• 0

  我的答案是未经测试的，就像在移动设备上一样 . 我不清楚你是否有一个现有的100个Excel文件列表，每个文件的代码和餐点，某个地方（你的主表图像只显示一行/文件） - 或者你是否想查找所有文件文件 .

  下面的代码尝试查找文件 .

  Option Explicit
  
  Sub InsertExternalReferences()
  
  ' Change if/as needed to the folder of the 100 Excel files. '
  Const FOLDER_PATH as string = "D:\Meals"
  
  Dim Filename as string
  Filename = dir$(folder_path &"\*-*.xlsx" , vbnormal)
  
  Dim Index as long
  Dim FileIndex as long
  
  ' Change this line to the name of the sheet that contains the MasterTable -- else you'll get an error. '
  With thisworkbook.worksheets("MasterTable")
  
  Do until Len(filename) = 0
  
  FileIndex = FileIndex + 1
  
  ' To me, does not make sense to use the INDEX function. It would make sense if you were looking up the value dynamically with a combination of INDEX and MATCH, but you do not appear to be. You may as well just give the cell reference if structure throughout 100 workbooks is not going to change. '
  
  ' Reading rows 2 to 8 on each Sheet1'
  For Index = 2 to 8
  
  'Index+2 below means we start writing from column 4 (AKA column D).'
  
  '5+ below means we are skipping the first 5 rows on the MasterTable sheet and begin writing from the sixth row. Change it to however many rows you need to skip.'
  
  .cells(5+FileIndex,Index+2).formula = "='" & folder_path & "[" & filename & "]Sheet1'!B" & cstr(Index)
  
  Next index
  
  Filename = dir$()
  Loop
  
  End with
  
  
  End sub
  

  如果我误解了，请告诉我 .

  回复于 2024-05-05T04:24:00+08:00