Question

我有一种情况，我正在将数据从多个文件复制到主文件，我希望在程序第一次运行时，它应该开始将数据粘贴到主文件中指定范围的文件中，这样可以正常工作。但是，当再次运行该程序时，它不会从先前的范围开始，而是开始将数据粘贴到先前记录的下面，这是重复的相同数据，我希望当用户第一次或多次运行该程序时，从第一次运行时所在的位置开始。以下是我的代码。

Sub Append()
 'Append data from other files
  Path = "E:\NPM PahseIII\"
 Dim c As Range

   'find the second empty cell in ColA
 Set c = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0)
   'target range for pasting data it first run this is actually pointing to 
   'my desire range but at second or multiple running the range is starting 
    'below at the previous record 
 Set targetcellL = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 1)
 Set targetcellR = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(5, 4)
 Filename = Dir(Path & "*.xlsx")
Do While Filename <> ""
If InStr(Filename, ".") > 0 Then
 Filenamenoext = Left(Filename, InStr(Filename, ".") - 1)
End If
   c.Value = Filenamenoext
   Set c = c.Offset(4, 0)

  Set wb = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)
Data = wb.Worksheets(1).Range("B3:E6").Value
wb.Worksheets(1).Range("B3:E6").Copy
ThisWorkbook.Activate
ActiveSheet.Range(targetcellL, targetcellR).Select
  ActiveSheet.Paste
  Set targetcellL = targetcellL.Offset(4, 0)
  Set targetcellR = targetcellR.Offset(5, 0)
Workbooks(Filename).Close
Filename = Dir()
Loop

End Sub

问题：我希望当程序运行尽可能多的时间时，它应该开始粘贴数据，这是它第一次粘贴数据的范围。以下图像将更精确地解决我的问题。程序第一次运行时，我粘贴的数据低于我想要的范围。

第二次运行时，我得到的数据低于范围我应该怎么做才能使程序运行多次，数据应粘贴在第一次运行时的范围内，如图所示。

Answer 1

这里有两种不同的方法：

Sub AppendValuesAndFormats()
'Append data from other files
    Const Path = "E:\NPM PahseIII\"
    Dim target As Range

    With ThisWorkbook.ActiveSheet
        .UsedRange.Offset(2).ClearContents
        Set target = .Range("A3")
    End With

    Filename = Dir(Path & "*.xlsx")

    Do While Filename <> ""
        With Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)
            target.Value = IIf(InStr(Filename, ".") > 0, Left(Filename, InStr(Filename, ".") - 1), "")
            .Worksheets(1).Range("B3:E6").Copy Destination:=target.Offset(0, 1)
            .Close SaveChanges:=False
        End With
        Set target = target.Offset(4)
        Filename = Dir()
    Loop

End Sub

Sub AppendValues()
'Append data from other files
    Const Path = "E:\NPM PahseIII\"
    Dim target As Range

    With ThisWorkbook.ActiveSheet
        .UsedRange.Offset(2).ClearContents
        Set target = .Range("A3")
    End With

    Filename = Dir(Path & "*.xlsx")
    Do While Filename <> ""
        With Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)
            target.Value = IIf(InStr(Filename, ".") > 0, Left(Filename, InStr(Filename, ".") - 1), "")
            target.Range("B1:E4").Value = .Worksheets(1).Range("B3:E6").Value
            .Close SaveChanges:=False
        End With
        Set target = target.Offset(4)
        Filename = Dir()
    Loop

End Sub

如何在Excel VBA中动态选择特定的单元格范围？

1 个答案: