VBA: Copy from folder

kris_friis

New Member
Joined
Nov 27, 2020
Messages
8
Office Version
  1. 2013
Platform
  1. Windows
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
VBA Code:
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
 
Last edited by a moderator:

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
55,253
Office Version
  1. 365
Platform
  1. Windows
Will col Aw on the sheets being copied also have data on every row?
 

Some videos you may like

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
55,253
Office Version
  1. 365
Platform
  1. Windows
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

New Member
Joined
Nov 27, 2020
Messages
8
Office Version
  1. 2013
Platform
  1. Windows
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
55,253
Office Version
  1. 365
Platform
  1. Windows
Ok, how about
VBA Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,126,998
Messages
5,622,097
Members
415,876
Latest member
csibonga2k17

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top