VBA: Copy from folder

[kris_friis]

Hi all,
I have written this code, but I have an issue: When it runs the second time (it should run daily) it deletes the previous data and past the new one from below what it deleted. It should delete the first and then paste from the second row

Sub MergeFiles()
Worksheets("Copy").Range("A1:AV12000").Clear
Dim path As String, ThisWB As String, lngFilecounter As Long
Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
Dim Filename As String, Wkb As Workbook
Dim CopyRng As Range, Dest As Range
    Dim RowofCopySheet As Integer
    RowofCopySheet = 2 ' Row to start on in the sheets you are copying from
    ThisWB = ActiveWorkbook.Name

    path = "C:\Users\OneDrive\PowerApp"
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Set shtDest = ActiveWorkbook.Sheets(1)
Filename = Dir(path & "\*.xlsx", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
If Not Filename = ThisWB Then
Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
CopyRng.Copy Dest
Wkb.Close False
End If

Filename = Dir()
Loop
Range("A2:AV300").Select

Application.EnableEvents = True
Application.ScreenUpdating = True

    MsgBox "Data is merged"
End Sub
Sub MergeFiles()
Worksheets("Copy").Range("A1:AV12000").Clear
Dim path As String, ThisWB As String, lngFilecounter As Long
Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
Dim Filename As String, Wkb As Workbook
Dim CopyRng As Range, Dest As Range
    Dim RowofCopySheet As Integer
    RowofCopySheet = 2 ' Row to start on in the sheets you are copying from
    ThisWB = ActiveWorkbook.Name

    path = "C:\Users\ksf008\OneDrive - Maersk Group\PowerApp\Mini Database"
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Set shtDest = ActiveWorkbook.Sheets(1)
Filename = Dir(path & "\*.xlsx", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
If Not Filename = ThisWB Then
Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
CopyRng.Copy Dest
Wkb.Close False
End If

Filename = Dir()
Loop
Range("A2:AV300").Select

Application.EnableEvents = True
Application.ScreenUpdating = True

    MsgBox "Data is merged"
End Sub

 

[Fluff]

Will col Aw on the sheets being copied also have data on every row?

 

[kris_friis]

It could be copied, if that helps!

 

[Fluff]

In the files being copied from the code needs to determine where the data ends (ie the last used row). Is there any column in those files that will always have data in every cell for that column?

 

[kris_friis]

Column B will also always have data, but each file has a different lenght and the lenght (number of rows) will also change daily

 

[Fluff]

Ok, how about

Sub krisfriis()
   Dim Pth As String, Fname As String
   Dim Ws As Worksheet
   Dim Wbk As Workbook, DestWbk As Workbook
   
   Application.ScreenUpdating = False
   
   Set DestWbk = ActiveWorkbook
   Set Ws = DestWbk.Sheets(1)
   Pth = "C:\Users\OneDrive\PowerApp\"
   Ws.Range("A11:AV" & Ws.Range("B" & Rows.Count).End(xlUp).Row).ClearContents
   
   Fname = Dir(Pth & "*.xlsx")
   Do Until Fname = ""
      If Fname <> DestWbk.Name Then
         Set Wbk = Workbooks.Open(Pth & Fname)
         With Wbk.Sheets(1)
            .Range("A2:AV" & .Range("B" & Rows.Count).End(xlUp).Row).Copy Ws.Range("B" & Rows.Count).End(xlUp).Offset(1, -1)
         End With
      End If
      Fname = Dir
   Loop
End Sub