具有动态范围的VBA复制/粘贴值到另一个工作簿中，包括动态文件路径查找

Question

Lengthy title but hopefully I can explain. What I am wanting to do is Copy/Paste values from active Workbook into another Workbook contained in the same directory "folder" as the active. I need the range of the copy to be dynamic in the sense that if I add lines to the current range, I want the code to automatically pick this up and not have to manually amend the range in the code.

I managed to find and slightly some code on StackOverflow which does what I need statically, but I have no idea how to add the various "dynamic" needs as my VBA knowledge is unfortunately not advanced enough. If you are able to assist, thanks very much in advance!

Code:

Public Sub CopyData()
Dim x As Workbook
Dim y As Workbook
Dim vals As Variant
Dim RemoveRows

Below is where I need the "Path" of the new Workbook to be dynamic. I thought maybe along the lines of Application.ActiveWorkbook.Path to find the path, as I've seen that before, but I couldn't really get it to work. It then also needs to add the filename extension of the destination Workbook, which I have specified on "Sheet 1" in cell F2 of the Active Workbook. ie the destination Workbook to open would be "ActiveWorkbook.Path + Sheet 1 cell F2 + .xls" if that makes sense. The reason for cell F2 is so that I can use this code with other Workbook names.

'Open workbook first:
Set x = Workbooks.Open("PATH")

Continue through code.

Set y = ThisWorkbook

Below Range is what I need to also be dynamic, ideally it would look in column A (starting in row 4), and create a copy/store range for all columns AP until the first blank cell is located in A (ie exactly as per below, but the 13 should automatically increase to say 15 if I add 2 more rows with text in column A.

'Store values in a variable:
vals = y.Sheets("Sheet1").Range("A4:P13").Value

Continue through code (paste/variable assign would need to be the exact same range as vals above except offset up by 2, ie should be A2 to P11 or P13 if rows added).

'Use the variable to assign a value to the other file/sheet:
x.Sheets("Sheet2").Range("A2:P11").Value = vals

'Delete Zero Rows
Set x = ActiveWorkbook
x.Sheets("Sheet2").Activate
For RemoveRows = Range("K65536").End(xlUp).Row To 1 Step -1
   If Cells(RemoveRows, 11).Value = 0 Then Rows(RemoveRows).EntireRow.Delete

Next RemoveRows

'Copy Paste Values Again to Sheet 1 to ensure formatting uncompromised
vals = x.Sheets("Sheet2").Range("A2:P1000").Value
x.Sheets("Sheet1").Range("A2:P1000").Value = vals
x.Sheets("Sheet2").Cells.Clear
x.Sheets("Sheet1").Activate

'Close x:
If x.Saved = False Then
    x.Save
End If
x.Close

End Sub

Answer 1

For the first question relating to the path, you are almost there, you just need to build the full string. The Application.activeworkbook.path returns the string that point to the directory of the activeworkbook, so you just need to addon the name of the file

For the dynamic ranges, you can use the Range.End property

For the transfer between worksheets/books I would suggest using the Range.Copy/paste properties. when pasting a range, you just need to specify the top left cell and excel will take care of the rest

I've made a few updates to make the worksheet references more explicit, avoid .activate, and a few other changes, but something like the below should do it:

Public Sub CopyData()
    Dim x As Workbook
    Dim y As Workbook
    Dim xWs1 As Worksheet
    Dim xWs2 As Worksheet
    Dim yWs As Worksheet
    Dim vals As Range
    Dim newVals As Range
    Dim RemoveRows
    Dim Path As String

    'build the Path
    Path = Application.ActiveWorkbook.Path & "\file.xlsx" 'as an alternative you could use the Application.FileDialog(msoFileDialogOpen) to promt the user to select the file

    'Open workbook first:
    Set x = Workbooks.Open(Path)
    Set xWs1 = x.Sheets("Sheet1")
    Set xWs2 = x.Sheets("Sheet2")

    Set y = ThisWorkbook
    Set yWs = y.Sheets("Sheet1")

    'reference values by a range:
    Set vals = yWs.Range("A4:P" & yWs.Range("A4").End(xlDown).Row)
    'copy/paste the range other file/sheet:
    vals.Copy xWs2.Range("A2")



    'Delete Zero Rows
    For RemoveRows = xWs2.Range("A2").End(xlDown).Row To 2 Step -1
        If xWs2.Cells(RemoveRows, 11).Value = 0 Then
            xWs2.Rows(RemoveRows).EntireRow.Delete
        End If
    Next RemoveRows

    'Copy Paste Values Again to Sheet 1 to ensure formatting uncompromised
    Set newVals = xWs2.Range("A2:P" & xWs2.Cells(1048576, 1).End(xlUp).Row)
    newVals.Copy xWs1.Range("A2")
    xWs2.Rows.EntireRow.Delete
    xWs1.Activate

    'Close x:
    If x.Saved = False Then
        x.Save
    End If
    x.Close

End Sub