+ Reply to Thread
Results 1 to 1 of 1

New to Excel programming. In need of a macro to combine multiple files with multiple tabs.

  1. #1
    Registered User
    Join Date
    04-10-2014
    Location
    La Joya, Tx
    MS-Off Ver
    Excel 2007
    Posts
    1

    New to Excel programming. In need of a macro to combine multiple files with multiple tabs.

    I am a beginner in excel programming. I need help from any or all the experts out there. The macro will combine multiple files with multiple tabs. All the files have the same amount of tabs plus have the same tab names and have the same format. Is it possible to combine all the files with all the tabs into one master file. The data from all the tabs will merge together into there perspective tabs. I have attach a sample file with the tabs and there appropriate formats.
    I found this code on the web and it works fine but I am having problems with the function code that I am using to count the cell colors. I am pasting the code to see if anyone can get the code with the function to work.

    Option Explicit
    Const NUMBER_OF_SHEETS = 13

    Public Sub Merge()
    Dim externWorkbookFilepath As Variant
    Dim externWorkbook As Workbook
    Dim I As Long
    Dim mainLastEnd(1 To NUMBER_OF_SHEETS) As Range
    Dim mainCurEnd As Range

    Application.ScreenUpdating = False

    ' Initialise

    ' Correct number of sheets
    Application.DisplayAlerts = False
    If ThisWorkbook.Sheets.Count < NUMBER_OF_SHEETS Then
    ThisWorkbook.Sheets.Add Count:=NUMBER_OF_SHEETS - ThisWorkbook.Sheets.Count
    ElseIf ThisWorkbook.Sheets.Count > NUMBER_OF_SHEETS Then
    For I = ThisWorkbook.Sheets.Count To NUMBER_OF_SHEETS + 1 Step 1
    ThisWorkbook.Sheets(I).Delete
    Next I
    End If
    Application.DisplayAlerts = True

    For I = 1 To NUMBER_OF_SHEETS
    Set mainLastEnd(I) = GetTrueEnd(ThisWorkbook.Sheets(I))
    Next I


    ' Load the data
    For Each externWorkbookFilepath In GetWorkbooks()
    Set externWorkbook = Application.Workbooks.Open(externWorkbookFilepath, , True)

    For I = 1 To NUMBER_OF_SHEETS

    If mainLastEnd(I).Row > 1 Then
    ' There is data in the sheet

    ' Copy new data (skip headings)
    externWorkbook.Sheets(I).Range("A2:" & GetTrueEnd(externWorkbook.Sheets(I)).Address).Copy ThisWorkbook.Sheets(I).Cells(mainLastEnd(I).Row + 1, 1)

    ' Find the end column and row
    Set mainCurEnd = GetTrueEnd(ThisWorkbook.Sheets(I))
    Else
    ' No nata in sheet yet (prob very first run)

    ' Get correct sheet name from first file we check
    ThisWorkbook.Sheets(I).Name = externWorkbook.Sheets(I).Name

    ' Copy new data (with headings)
    externWorkbook.Sheets(I).Range("A1:" & GetTrueEnd(externWorkbook.Sheets(I)).Address).Copy ThisWorkbook.Sheets(I).Cells(mainLastEnd(I).Row, 1)

    ' Find the end column and row
    Set mainCurEnd = GetTrueEnd(ThisWorkbook.Sheets(I)).Offset(, 1)

    ' Add file name heading
    ThisWorkbook.Sheets(I).Cells(1, mainCurEnd.Column).Value = "File Name"
    End If

    ' Add file name into extra column
    ThisWorkbook.Sheets(I).Range(ThisWorkbook.Sheets(I).Cells(mainLastEnd(I).Row + 1, mainCurEnd.Column), mainCurEnd).Value = externWorkbook.Name

    Set mainLastEnd(I) = mainCurEnd
    Next I

    externWorkbook.Close
    Next externWorkbookFilepath

    Application.ScreenUpdating = True
    End Sub

    ' Returns a collection of file paths, or an empty collection if the user selects cancel
    Private Function GetWorkbooks() As Collection
    Dim fileNames As Variant
    Dim xlFile As Variant

    Set GetWorkbooks = New Collection

    fileNames = Application.GetOpenFilename(Title:="Please choose the files to merge", _
    FileFilter:="Excel Files, *.xls*;*.xlsx", _
    MultiSelect:=True)
    If TypeName(fileNames) = "Variant()" Then
    For Each xlFile In fileNames
    GetWorkbooks.Add xlFile
    Next xlFile
    End If
    End Function

    ' Finds the true end of the table (excluding unused columns/rows and rows filled with 0's)
    Private Function GetTrueEnd(ws As Worksheet) As Range
    Dim lastRow As Long
    Dim lastCol As Long
    Dim r As Long
    Dim C As Long

    On Error Resume Next
    lastCol = ws.UsedRange.Find("*", , , xlPart, xlByColumns, xlPrevious).Column
    lastRow = ws.UsedRange.Find("*", , , xlPart, xlByRows, xlPrevious).Row
    On Error GoTo 0

    If lastCol <> 0 And lastRow <> 0 Then

    ' look back through the last rows of the table, looking for a non-zero value
    For r = lastRow To 1 Step -1
    For C = 1 To lastCol
    If ws.Cells(r, C).Text <> "" Then
    If ws.Cells(r, C).Text <> 0 Then
    Set GetTrueEnd = ws.Cells(r, lastCol)
    Exit Function
    End If
    End If
    Next C
    Next r
    End If

    Set GetTrueEnd = ws.Cells(1, 1)
    End Function

    Option Explicit

    Private Function CountCFCells(Rng As Range, C As Range)
    Dim I As Single, j As Long, k As Long
    Dim chk As Boolean, Str1 As String, CFCELL As Range
    chk = False
    For I = 1 To Rng.FormatConditions.Count
    If Rng.FormatConditions(I).Interior.ColorIndex = C.Interior.ColorIndex Then
    chk = True
    Exit For
    End If
    Next I
    j = 0
    k = 0
    If chk = True Then
    For Each CFCELL In Rng
    Str1 = CFCELL.FormatConditions(I).Formula1
    Str1 = Application.ConvertFormula(Str1, xlA1, xlR1C1)
    Str1 = Application.ConvertFormula(Str1, xlR1C1, xlA1, , ActiveCell.Resize(Rng.Rows.Count, Rng.Columns.Count).Cells(k + 1))
    If Evaluate(Str1) = True Then j = j + 1
    k = k + 1

    Next CFCELL
    Else
    CountCFCells = "Color not found"
    Exit Function
    End If
    CountCFCells = j
    End Function


    The function that I am using to count the the cell colors is:

    Private Function CountCFCells(Rng As Range, C As Range)
    Dim I As Single, j As Long, k As Long
    Dim chk As Boolean, Str1 As String, CFCELL As Range
    chk = False
    For I = 1 To Rng.FormatConditions.Count
    If Rng.FormatConditions(I).Interior.ColorIndex = C.Interior.ColorIndex Then
    chk = True
    Exit For
    End If
    Next I
    j = 0
    k = 0
    If chk = True Then
    For Each CFCELL In Rng
    Str1 = CFCELL.FormatConditions(I).Formula1
    Str1 = Application.ConvertFormula(Str1, xlA1, xlR1C1)
    Str1 = Application.ConvertFormula(Str1, xlR1C1, xlA1, , ActiveCell.Resize(Rng.Rows.Count, Rng.Columns.Count).Cells(k + 1))
    If Evaluate(Str1) = True Then j = j + 1
    k = k + 1

    Next CFCELL
    Else
    CountCFCells = "Color not found"
    Exit Function
    End If
    CountCFCells = j
    End Function
    Attached Files Attached Files
    Last edited by nflores0303; 04-13-2016 at 10:45 PM. Reason: Found code on Web and worked.

+ Reply to Thread

Thread Information

Users Browsing this Thread

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

Similar Threads

  1. Extracting multiple webpages (1 website, multiple tabs) into excel using a macro
    By Rjk214 in forum Excel Programming / VBA / Macros
    Replies: 0
    Last Post: 03-17-2015, 05:27 PM
  2. Replies: 2
    Last Post: 11-02-2014, 01:31 AM
  3. Macro to combine same-named sheets from multiple files
    By virsilens in forum Excel Programming / VBA / Macros
    Replies: 3
    Last Post: 09-13-2014, 12:05 AM
  4. Macro to combine and clean multiple files
    By micahjb in forum Excel Programming / VBA / Macros
    Replies: 1
    Last Post: 08-12-2013, 07:16 PM
  5. Replies: 2
    Last Post: 05-06-2013, 06:41 PM
  6. Consolidating multiple files into one excel file with multiple tabs
    By Chemistification in forum Excel Programming / VBA / Macros
    Replies: 4
    Last Post: 06-13-2012, 06:23 AM
  7. Macro for multiple workbook files and various tabs
    By blondewithbrains in forum Excel Programming / VBA / Macros
    Replies: 1
    Last Post: 08-05-2011, 05:07 PM

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