VBA Pasting/looping

Curtisyoung78

New Member
Joined
Jun 19, 2017
Messages
25
I have a vba code to get info from multiple workbooks then paste them consecutively in one worksheet. I want the macro to paste to cell A1 everytime i run the macro, after clearing contents of the previous time i ran it of course. But instead it pastes to the last cell used from the last time i ran the macro + 1 row.

I have ran the macro 50 times or so and is now pasting to row 3500. How can i get it to paste to cell A1 everytime i run it? I have pasted the vba code below.

'Description: Combines all files in a folder to a master file.
Sub MergeFiles()
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 = ("T:\Curtis\Pile Data")


Application.EnableEvents = False
Application.ScreenUpdating = False


Set shtDest = ActiveWorkbook.Sheets(1)
Filename = Dir(path & "\*.xls", 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("A1").Select

Application.EnableEvents = True
Application.ScreenUpdating = True



End Sub
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Try:
Code:
Sub MergeFiles_v1()

    Dim wkb         As Workbook
    Dim LR          As Long
    Dim LC          As Long
    Dim arr()       As Variant
    Dim filename    As String
    Const path      As String = "T:\Curtis\Pile Data\"
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With


    filename = Dir(path & "\*.xls", vbNormal)
    If Len(filename) = 0 Then Exit Sub
    
    Do Until filename = vbNullString
        If Not filename = ThisWorkbook.Name Then
            Set wkb = Workbooks.Open(path & filename)
            With wkb
                With .Sheets(1)
                    LR = .Cells(.Rows.Count, 1).End(xlUp).row
                    LC = .Cells(1, .Columns.Count).End(xlToLeft).Column
                    arr = .Cells(2, 1).Resize(LR - 1, LC).Value
                End With
                .Close False
            End With
            Set wkb = Nothing
            
            With ActiveWorkbook.Sheets(1)
                LR = .Cells(.Rows.Count, 1).End(xlUp).Offset(1).row
                .Cells(LR + 1, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
                Erase arr
            End With
        End If
        filename = Dir()
    Loop
            
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
End Sub
 
Last edited:
Upvote 0
Try:
Code:
Sub MergeFiles_v1()

    Dim wkb         As Workbook
    Dim LR          As Long
    Dim LC          As Long
    Dim arr()       As Variant
    Dim filename    As String
    Const path      As String = "T:\Curtis\Pile Data\"
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With


    filename = Dir(path & "\*.xls", vbNormal)
    If Len(filename) = 0 Then Exit Sub
    
    Do Until filename = vbNullString
        If Not filename = ThisWorkbook.Name Then
            Set wkb = Workbooks.Open(path & filename)
            With wkb
                With .Sheets(1)
                    LR = .Cells(.Rows.Count, 1).End(xlUp).row
                    LC = .Cells(1, .Columns.Count).End(xlToLeft).Column
                    arr = .Cells(2, 1).Resize(LR - 1, LC).Value
                End With
                .Close False
            End With
            Set wkb = Nothing
            
            With ActiveWorkbook.Sheets(1)
                LR = .Cells(.Rows.Count, 1).End(xlUp).Offset(1).row
                .Cells(LR + 1, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
                Erase arr
            End With
        End If
        filename = Dir()
    Loop
            
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
End Sub


Works perfectly, exactly what i was looking for. Thanks very much JacDanIce.
 
Upvote 0

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

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
Back
Top