1. Computer problem? Tech Support Guy is completely free -- paid for by advertisers and donations. Click here to join today! If you're new to Tech Support Guy, we highly recommend that you visit our Guide for New Members.

Help!: Excel Macro; copy multiple files into one file

Discussion in 'Software Development' started by v8turbo.snail, Oct 13, 2008.

Thread Status:
Not open for further replies.
  1. v8turbo.snail

    v8turbo.snail Thread Starter

    Joined:
    Oct 12, 2008
    Messages:
    1
    Hi excel-macro experts, I am writing a data-compiling macro which does, 1)select folder, 2)open xls files in the folder, 3)select all data for each file (only sheet 1 has data), 4)create a new file in the folder (let's say summary file), 5)paste data selected in the process (3) to the summary file created. With a lot of help from many websites, the following macro has been created. However, there is a PROBLEM that is when the data are pasted, all data were pasted into one column (sorce data of each original file has many columns). I need to avoid this. All I want is pasting the source data to Sheet1 of the summary file with the same number of columns (all source data files has the same number of columns) as the sorcce data has. Your help would be greately appreciated!!!

    Function RDB_Last(choice As Integer, rng As Range)

    ' A choice of 1 = last row.
    ' A choice of 2 = last column.
    ' A choice of 3 = last cell.
    Dim lrw As Long
    Dim lcol As Integer
    Select Case choice
    Case 1:
    On Error Resume Next
    RDB_Last = rng.Find(What:="*", _
    After:=rng.Cells(1), _
    LookAt:=xlPart, _
    LookIn:=xlFormulas, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious, _
    MatchCase:=False).Row
    On Error GoTo 0
    Case 2:
    On Error Resume Next
    RDB_Last = rng.Find(What:="*", _
    After:=rng.Cells(1), _
    LookAt:=xlPart, _
    LookIn:=xlFormulas, _
    SearchOrder:=xlByColumns, _
    SearchDirection:=xlPrevious, _
    MatchCase:=False).Column
    On Error GoTo 0
    Case 3:
    On Error Resume Next
    lrw = rng.Find(What:="*", _
    After:=rng.Cells(1), _
    LookAt:=xlPart, _
    LookIn:=xlFormulas, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious, _
    MatchCase:=False).Row
    On Error GoTo 0
    On Error Resume Next
    lcol = rng.Find(What:="*", _
    After:=rng.Cells(1), _
    LookAt:=xlPart, _
    LookIn:=xlFormulas, _
    SearchOrder:=xlByColumns, _
    SearchDirection:=xlPrevious, _
    MatchCase:=False).Column
    On Error GoTo 0
    On Error Resume Next
    RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
    If Err.Number > 0 Then
    RDB_Last = rng.Cells(1).Address(False, False)
    Err.Clear
    End If
    On Error GoTo 0
    End Select
    End Function

    'Public Function GetStartFolder()
    'GetStartFolder = "c:\Data"
    'End Function


    Sub CompileAllWorkbooks()

    Dim myFolder As Variant
    Dim myFolderPth As Variant
    Dim Msg As String

    Dim FirstCell As String
    Dim MyPath As Variant, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, FNum As Long
    Dim sourceLcount As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long
    Dim lnum As Long

    'Select a folder
    With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    myFolder = .SelectedItems(1)
    End With

    ' Change this to the path\folder location of your files.
    MyPath = myFolderPath
    ' Add a slash at the end of the path if needed.
    If Right(MyPath, 1) <> "\" Then
    MyPath = MyPath & "\"
    End If

    ' If there are no Excel files in the folder, exit.
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
    MsgBox "No files found"
    Exit Sub
    End If

    FNum = 0
    Do While FilesInPath <> ""
    FNum = FNum + 1
    ReDim Preserve MyFiles(1 To FNum)
    MyFiles(FNum) = FilesInPath
    FilesInPath = Dir()
    Loop

    ' Set various application properties.
    With Application
    'CalcMode = .Calculation
    .ScreenUpdating = False
    .EnableEvents = False
    End With

    ' Add a new workbook with one sheet.
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    rnum = 1
    lnum = 1

    ' Loop through all files in the myFiles array.
    If FNum > 0 Then
    For FNum = LBound(MyFiles) To UBound(MyFiles)
    Set mybook = Nothing
    On Error Resume Next
    Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
    On Error GoTo 0
    If Not mybook Is Nothing Then
    On Error Resume Next

    ' Change this range to fit your own needs.

    With mybook.Worksheets(1)
    Set sourceRange = .Range(selection, ActiveCell.SpecialCells(xlLastCell))
    End With

    If Err.Number > 0 Then
    Err.Clear
    Set sourceRange = Nothing
    Else
    ' If source range uses all columns then
    ' skip this file.
    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
    Set sourceRange = Nothing
    End If
    End If
    On Error GoTo 0
    If Not sourceRange Is Nothing Then
    SourceRcount = sourceRange.Rows.Count
    sourceLcount = sourceRange.Columns.Count
    If rnum + SourceRcount >= BaseWks.Rows.Count Then
    MsgBox "There are not enough rows in the target worksheet."
    BaseWks.Columns.AutoFit
    mybook.Close savechanges:=False
    GoTo ExitTheSub
    Else

    ' Set the destination range.
    Set destrange = BaseWks.Range("A65535").End(xlUp)

    ' Copy the values from the source range
    ' to the destination range.
    With sourceRange
    Set destrange = destrange. _
    Resize(.Rows.Count, .Columns.Count)
    End With
    destrange.Value = sourceRange.Value
    rnum = rnum + SourceRcount
    lnum = lrum + sourceLcount
    End If
    End If
    mybook.Close savechanges:=False
    End If
    Next FNum
    BaseWks.Columns.AutoFit
    End If
    ExitTheSub:
    ' Restore the application properties.
    With Application
    .ScreenUpdating = True
    .EnableEvents = True
    End With

    End Sub
     
  2. MRdNk

    MRdNk

    Joined:
    Apr 7, 2007
    Messages:
    439
    Can you put your code in the CODE blocks (there is a button in "Go Advanced" mode)? It'll make it much easier to read - that is, if you've indented your code.
     
As Seen On
As Seen On...

Welcome to Tech Support Guy!

Are you looking for the solution to your computer problem? Join our site today to ask your question. This site is completely free -- paid for by advertisers and donations.

If you're not already familiar with forums, watch our Welcome Guide to get started.

Join over 733,556 other people just like you!

Loading...
Thread Status:
Not open for further replies.

Short URL to this thread: https://techguy.org/758618

  1. This site uses cookies to help personalise content, tailor your experience and to keep you logged in if you register.
    By continuing to use this site, you are consenting to our use of cookies.
    Dismiss Notice