Question

我有一个正在运行的宏，它从文件夹中的多个文件中提取数据，并将该文件中的内容粘贴到一个主文件中。所有数据都正确地粘贴在主文件中，但是我需要将数据的名称也粘贴到主文件中。

我的宏是：

  Dim MyFile As String, Sep As String

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False

    Dim wks1 As Worksheet, wks2 As Worksheet, objwb As Workbook, objwb0 As Workbook
    Dim last_rowcurent As Long
    Dim last_row As Long
        Sheets("Warnings").Select
    last_rowcurent = Range("B1").End(xlDown).Row + 1
    Set objwb0 = ActiveWorkbook
    Set wks1 = objwb0.Worksheets("Warnings")


  ' Sets up the variable "MyFile" to be each file in the directory
  ' This example looks for all the files that have an .xls extension.
  ' This can be changed to whatever extension is needed. Also, this
  ' macro searches the current directory. This can be changed to any
  ' directory.

  '' Test for Windows or Macintosh platform. Make the directory request.
  Sep = Application.PathSeparator

  'If Sep = "\" Then
     ' Windows platform search syntax.
     MyFile = Dir("P:\Frame\Frame_Piercing\Metrics_Development\Inmagusa\Warnings" & Sep & "*.xls")

  'Else

     ' Macintosh platform search syntax.
     'MyFile = Dir("", MacID("XLS5"))
  'End If

  ' Starts the loop, which will continue until there are no more files
  ' found.
  Do While MyFile <> ""
    Application.ScreenUpdating = False
    Application.CutCopyMode = False

     ' Displays a message box with the name of the file. This can be
     ' changed to any procedure that would be needed to run on every
     ' file in the directory such as opening each file.
    last_rowcurent = wks1.Range("B2").End(xlDown).Row + 1
    Set objwb = Workbooks.Open("P:\Frame\Frame_Piercing\Metrics_Development\Inmagusa\Warnings" & Sep & MyFile)
    Set wks2 = objwb.Worksheets("navistar-warnings")
        Sheets("navistar-warnings").Select
    last_row = wks2.Range("A2").End(xlDown).Row
    If Not IsEmpty(Range("A2")) Then



        'MsgBox last_row
        wks2.Range("A2:h" & last_row).Select
        Selection.Copy
        Workbooks("Inmagusa_Merge_Files.xlsm").Activate
        Worksheets("Warnings").Range("A1").Select
        'Sheets("Errors").Select
        last_rowcurent = ActiveSheet.Range("B1").End(xlDown).Row + 1
        ActiveSheet.Range("A" & last_rowcurent).Select
        'ActiveWorkbook.Worksheets("Release").Range("A" & lastrowcurent).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        'Selection.PasteSpecial Paste:=x1PasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=True, Transpose:=False

        'wks1.Range("A" & last_rowcurent).PasteSpecial(Paste:=x1PasteValues, Paste:=x1PasteFormats, Operation:= _
        x1None, SkipBlanks:=False, Transpose:=False)
        'wks1.Range("A" & last_rowcurent).Select
        'Selection.PasteSpecial Paste:=xlPasteValues, x1PasteFormats, Operation:= _
        'xlNone, SkipBlanks:=False, Transpose:=False

        'wks2.Range("A4:w" & last_row).Copy
        'wks1.Range("A" & last_rowcurent).Select
        'Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        'SkipBlanks:=False, Transpose:=False

        'Workbooks("Frame_WorkPlanning_Master.xlsm").Activate
        'last_rowcurent = ActiveWorkbook.Worksheets("Release").Range("A3").Row
        'ActiveWorkbook.Worksheets("Release").Range("a3").Paste
           'With wks1.Range("A" & last_rowcurent)
               '.PasteSpecial Paste:=xlPasteColumnWidths
               '.PasteSpecial Paste:=xlPasteFormats
               '.PasteSpecial Paste:=xlValue
                'or other parameters...
           'End With
    End If
       objwb.Close False


     'MsgBox "P:\Frame\Work_Planning\Engineer_Plans" & Sep & MyFile
     MyFile = Dir()
  Loop
'ActiveWorkbook.Worksheets("Release").Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
False, AllowSorting:=True, AllowFiltering:=True, AllowFormattingCells:=True, AllowUsingPivotTables:= _

我需要在“I”列中粘贴文件名，但行数因每个单独文件中的数据而异。

非常感谢任何帮助！

Answer 1

你有很多注释掉的代码，这使得它有点难以理解。我忽略了所有注释的代码并重写了有问题的部分以消除Active＆amp; Select。请参阅此post，详细了解这是一个好主意的原因。

文件名现在打印在要粘贴的新数据的第一行的I列中

Dim wbSource As Workbook
Set wbSource = Workbooks("Inmagusa_Merge_Files.xlsm")

If Not IsEmpty(Range("A2")) Then
    wks2.Range("A2:h" & last_row).Copy

    last_rowcurent = wbSource.Worksheets("Warnings").Range("B1").End(xlDown).Row + 1

    ' Put file name in Column I on the first row of new data
    wbSource.Worksheets("Warnings").Range("I" & last_rowcurent).Value = objwb.Name

    wbSource.Worksheets("Warnings").Range("A" & last_rowcurent).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If

修改

要在列I中粘贴新数据的每一行，您可以像这样循环：

Dim wbSource As Workbook Set wbSource = Workbooks("Inmagusa_Merge_Files.xlsm") If Not IsEmpty(Range("A2")) Then Dim copyRange As Range Set copyRange = wks2.Range("A2:h" & last_row) copyRange.Copy last_rowcurent = wbSource.Worksheets("Warnings").Range("B1").End(xlDown).Row + 1 ' Put file name in Column I on the first row of new data 'wbSource.Worksheets("Warnings").Range("I" & last_rowcurent).Value = objwb.Name ' Put file name in Column I for every row being pasted For j = 1 + last_rowcurent To copyRange.Rows.Count + last_rowcurent wbSource.Worksheets("Warnings").Range("I" & j).Value = objwb.Name Next j wbSource.Worksheets("Warnings").Range("A" & last_rowcurent).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False End If

请注意，我注释掉单行代码并添加到For循环中以打印每个单元格的名称。

从多个文件中提取数据并在Excel中相应地命名数据

1 个答案: