Snasui Excel Forum

Code: Select all

Sub GetData()
    
    Dim WS_count As Integer
    Dim i As Integer
    WS_count = Worksheets.Count
    
    
    Application.DisplayAlerts = False
    On Error Resume Next
    Dim Directory As String, f As String
    Application.ScreenUpdating = False
    
    Application.Goto Reference:="Area_TempDB"
    Application.CutCopyMode = False
    Selection.ClearContents
    
    Directory = ThisWorkbook.Path & "\"
    f = Dir(Directory)
    If f <> ThisWorkbook.Name Then
        Workbooks.Open Filename:=ThisWorkbook.Path & "\" & f
                CopyPaste
    End If
    Do While f <> ""
        f = Dir
        If f <> "" And f <> ThisWorkbook.Name Then
            Workbooks.Open Filename:=ThisWorkbook.Path & "\" & f
            'For i = 1 To WS_count
                CopyPaste
            'Next i
            'ActiveWorkbook.Close
        End If
    Loop
    Application.ScreenUpdating = True
End Sub

Sub CopyPaste()

    'Sheets(i).Activate
    Application.Goto Reference:="R1C1:R1000C9"
    Selection.Copy
    ActiveWorkbook.Close
    Application.Goto Reference:="Target"
    ActiveSheet.Paste
End Sub

Code: Select all

Sub GetData()
    Dim WS_count As Integer
    Dim i As Integer
    Dim wb As Workbook
    Dim Target As Range
    Dim wbo As Workbook
    
    Set wbo = ThisWorkbook
    Application.DisplayAlerts = False
    On Error Resume Next
    Dim Directory As String, f As String
    Application.ScreenUpdating = False
    
    Application.Goto Reference:="Area_TempDB"
    Application.CutCopyMode = False
    Selection.ClearContents
    
    Directory = ThisWorkbook.Path & "\"
    f = Dir(Directory)
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Workbooks.Open Filename:=ThisWorkbook.Path & "\" & f
            Set wb = ActiveWorkbook
            WS_count = wb.Worksheets.Count
            For i = 1 To WS_count
                Set Target = wbo.Sheets("DB").Range("A" & Rows.Count) _
                    .End(xlUp).Offset(1, 0)
                wb.Worksheets(i).Range("A2:I1000").Copy Target
            Next i
            wb.Close
        End If
        f = Dir
    Loop
    Application.ScreenUpdating = True
End Sub