Closed Thread
Results 1 to 2 of 2

Macro Merge Cells with Values

Hybrid View

angel56 Macro Merge Cells with Values 12-15-2007, 11:45 AM
royUK You now have three posts on... 12-15-2007, 12:07 PM
  1. #1
    Registered User
    Join Date
    11-30-2007
    Posts
    44

    Cool Macro Merge Cells with Values

    I'm using Excel 2007. this code runs but need some tweking.
    This macro merges worbooks inside my Temp Folder however I only want to merge only the cells with values. Or maybe select the entire sheet rather small Range like ("A1:M10").

    Here is the code.


    
    Sub Merge_Macro_1()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    
    'Enter in the path\folder where the excel files are located
    MyPath = "C:\Documents and Settings\angel_r\Desktop\Temp\"
    
    'Add a slash at the end of path if missing
    If Right(MyPath, 1) <> "\" Then
    MyPath = MyPath & "\"
    End If
    
    'Look for Excel files if there are no Excel files in the folder exit the sub and display Msgbox
    FilesInPath = Dir(MyPath & "*.xls*")
    If FilesInPath = "" Then
    MsgBox "You big Dummy the folder is empty"
    Exit Sub
    End If
    
    
    'Fill the array(myFiles)with the list of Excel files from the folder
    Fnum = 0
    Do While FilesInPath <> ""
    Fnum = Fnum + 1
    ReDim Preserve MyFiles(1 To Fnum)
    MyFiles(Fnum) = FilesInPath
    FilesInPath = Dir()
    Loop
    
    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
    End With
    
    'Add a new workbook with only one sheet
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    rnum = 1
    
    'Loop through all excel files in the array(myFiles)
    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
    
    With mybook.Worksheets(1)
    
    Set sourceRange = .Range("A1:M10")
    
    End With
    
    If Err.Number > 0 Then
    Err.Clear
    Set sourceRange = Nothing
    Else
    'if SourceRange use 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
    
    If rnum + SourceRcount >= BaseWks.Rows.Count Then
    MsgBox "Sorry there are not enough rows in the sheet"
    BaseWks.Columns.AutoFit
    mybook.Close SaveChanges:=False
    GoTo ExitTheSub
    Else
    
    'Copy the name of each file in column A
    With sourceRange
    BaseWks.Cells(rnum, "A"). _
    Resize(.Rows.Count).Value = MyFiles(Fnum)
    End With
    
    'Set the destination range
    Set destrange = BaseWks.Range("B" & rnum)
    
    'copy the values from the sourceRange to the destination range
    With sourceRange
    Set destrange = BaseWks.Cells(rnum, "B"). _
    Resize(.Rows.Count, .Columns.Count)
    End With
    destrange.Value = sourceRange.Value
    
    rnum = rnum + SourceRcount
    End If
    End If
    mybook.Close SaveChanges:=False
    End If
    
    Next Fnum
    BaseWks.Columns.AutoFit
    End If
    
    ExitTheSub:
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = CalcMode
    End With
    End Sub

  2. #2
    Forum Expert royUK's Avatar
    Join Date
    11-18-2003
    Location
    Derbyshire,UK
    MS-Off Ver
    Xp; 2007; 2010
    Posts
    26,200
    You now have three posts on this subject. I have already told you about bumping posts not duplicating them!
    Hope that helps.

    RoyUK
    --------
    For Excel Tips & Solutions, free examples and tutorials why not check out my web site

    Free DataBaseForm example

Closed Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1