如何从已关闭的文件中读取标题并使用VBA将其作为列粘贴到新工作表中

Question

我在一个文件夹中有10个以上的文件。我想将所有文件标题作为列复制到新工作表。我能够做到这一点。但我想复制文件名和工作表名称也尝试但没有获取数据。 请参阅附件和下面的代码。

代码：

Public Sub CommandButton1_Click()
'DECLARE AND SET VARIABLES
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim mainwb As Workbook
Dim ws As Worksheet
 Dim search_result As Range   'range search result
    Dim blank_cell As Long
Dim wb As Workbook
Workbooks("abc.xlsm").Activate
input_directory = Sheets("SystemConfiguration").Range("B2").Value & "\"
 Filename = Dir(input_directory & "*.xls")

'--------------------------------------------
'OPEN EXCEL FILES
 Do While Len(Filename) > 0  'IF NEXT FILE EXISTS THEN
    Set wbk = Workbooks.Open(input_directory & Filename)
  Set wbk = ActiveWorkbook
  Filename = ActiveWorkbook.Name
  Variable = ActiveSheet.Name
 ActiveSheet.UsedRange.Rows(1).Copy

 Workbooks("newfile.xlsm").Activate
'ActiveWorkbook.ActiveSheet
 Set wb = ActiveWorkbook
  Set ws = wb.Sheets("Sheet1")

    For Each cell In ws.Columns(7).Cells
        If IsEmpty(cell) = True Then cell.Select: Exit For
    Next cell

 Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True

    wbk.Close savechanges:=False
    Filename = Dir
Loop
End Sub

此输出正在获得Mr.Mrig 期待这个输出

Mr.Mrig这是我改变后的代码

Public Sub CommandButton1_Click()
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim mainwb As Workbook
Dim ws As Worksheet
Dim wb As Workbook
Dim variable As String
Dim rowCount As Long
 Dim add As Range
Workbooks("abc.xlsm").Activate
input_directory = Sheets("SystemConfiguration").Range("B2").Value & "\"
 Filename = Dir(input_directory & "*.xls")
 Do While Len(Filename) > 0  'IF NEXT FILE EXISTS THEN
    Set wbk = Workbooks.Open(input_directory & Filename)
  Set wbk = ActiveWorkbook
  Filename = ActiveWorkbook.Name
  variable = ActiveSheet.Name
 ActiveSheet.UsedRange.Rows(1).Copy
 Workbooks("abc.xlsm").Activate
 Set wb = ActiveWorkbook
  Set ws = wb.Sheets("Sheet1")
    For Each cell In ws.Columns(12).Cells
        If IsEmpty(cell) = True Then cell.Select: Exit For
    Next cell
 Set add = Selection

 Selection.Offset(0, 2).PasteSpecial Paste:=xlPasteValues, Transpose:=True
 rowCount = Selection.Rows.Count
 Range(add, add.Offset(rowCount - 1, 0)).Value = Filename
 Range(add.Offset(0, 1), add.Offset(rowCount - 1, 1)).Value = variable
    wbk.Close savechanges:=False
    Filename = Dir
Loop
End Sub

Answer 1

对您的代码进行了一些更改。

替换以下行

Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True

到

 Selection.Value = Filename    '-->display file name in Column G(7)
 Selection.Offset(0, 1).Value = variable    '-->display sheet name in Column H(8)
 Selection.Offset(0, 2).PasteSpecial Paste:=xlPasteValues, Transpose:=True    '-->display header in Column I(9)

编辑： 的 ------------------------------------------------------------------------

 Dim rowCount As Long
 Dim add As Range
 Set add = Selection

 Selection.Offset(0, 2).PasteSpecial Paste:=xlPasteValues, Transpose:=True
 rowCount = Selection.Rows.Count
 Range(add, add.Offset(rowCount - 1, 0)).Value = Filename
 Range(add.Offset(0, 1), add.Offset(rowCount - 1, 1)).Value = variable