VBA copy conditional Formatting

Mnet22

New Member
Joined
Sep 17, 2017
Messages
37
I have a script that copies different workbooks to a new workbook. The only thing that is not copied over is my Conditional Formatting...Any help will be greatly appreciated.
VBA Code:
Option Explicit
Public Sub CombineManyWorkbooksIntoOneWorksheet()
    
    Dim strDirContainingFiles As String, strFile As String, _
        strFilePath As String
    Dim wbkDst As Workbook, wbkSrc As Workbook
    Dim wksDst As Worksheet, wksSrc As Worksheet
    Dim lngIdx As Long, lngSrcLastRow As Long, _
        lngSrcLastCol As Long, lngDstLastRow As Long, _
        lngDstLastCol As Long, lngDstFirstFileRow As Long
    Dim rngSrc As Range, rngDst As Range, rngFile As Range
    Dim colFileNames As Collection
    Set colFileNames = New Collection
    
    'Set references up-front
    strDirContainingFiles = "G:\Maps\WorkingFiles\2021 Projects\Sept 2021\Project test data\Other\Test\Test\" '<~ your folder
    Set wbkDst = Workbooks.Add '<~ Dst is short for destination
    Set wksDst = wbkDst.ActiveSheet
    
    'Store all of the file names in a collection
    strFile = Dir(strDirContainingFiles & "\*.xlsx")
    Do While Len(strFile) > 0
        colFileNames.Add Item:=strFile
        strFile = Dir
    Loop
    
    ''CHECKPOINT: make sure colFileNames has the file names
    'Dim varDebug As Variant
    'For Each varDebug In colFileNames
    '    Debug.Print varDebug
    'Next varDebug
    
    'Now we can start looping through the "source" files
    'and copy their data to our destination sheet
    For lngIdx = 1 To colFileNames.Count
        
        'Assign the file path
        strFilePath = strDirContainingFiles & "\" & colFileNames(lngIdx)
        
        'Open the workbook and store a reference to the data sheet
        Set wbkSrc = Workbooks.Open(strFilePath)
        Set wksSrc = wbkSrc.Worksheets("Report") '<~ change based on your Sheet name
        
        'Identify the last row and last column, then
        'use that info to identify the full data range
        lngSrcLastRow = LastOccupiedRowNum(wksSrc)
        lngSrcLastCol = LastOccupiedColNum(wksSrc)
        With wksSrc
            Set rngSrc = .Range(.Cells(1, 1), .Cells(lngSrcLastRow, _
                                                     lngSrcLastCol))
        End With
        
        ''CHECKPOINT: make sure we have the full source data range
        'wksSrc.Range("A1").Select
        'rngSrc.Select
        
        'If this is the first (1st) loop, we want to keep
        'the header row from the source data, but if not then
        'we want to remove it
        
       ' If lngIdx <> 1 Then
           ' Set rngSrc = rngSrc.Offset(1, 0).Resize(rngSrc.Rows.Count - 1)
       ' End If
        
            
        'Copy the source data to the destination sheet, aiming
        'for cell A1 on the first loop then one past the
        'last-occupied row in column A on each following loop
        If lngIdx = 1 Then
            lngDstLastRow = 1
            Set rngDst = wksDst.Cells(1, 1)
        Else
            lngDstLastRow = LastOccupiedRowNum(wksDst)
            Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
        End If
        rngSrc.Copy Destination:=rngDst '<~ this is the copy / paste
        rngDst.PasteSpecial Paste:=xlPasteFormats
        rngDst.PasteSpecial Paste:=xlPasteValues
        
        
        'Almost done! We want to add the source file info
        'for each of the data blocks to our destination
        
        'On the first loop, we need to add a "Source Filename" column
        If lngIdx = 1 Then
            lngDstLastCol = LastOccupiedColNum(wksDst)
            wksDst.Cells(1, lngDstLastCol + 1) = "Source Filename"
        End If
        
        'Identify the range that we need to write the source file
        'info to, then write the info
        With wksDst
        
            'The first row we need to write the file info to
            'is the same row where we did our initial paste to
            'the destination file
            lngDstFirstFileRow = lngDstLastRow + 1
            
            'Then, we need to find the NEW last row on the destination
            'sheet, which will be further down (since we pasted more
            'data in)
            lngDstLastRow = LastOccupiedRowNum(wksDst)
            lngDstLastCol = LastOccupiedColNum(wksDst)
            
            'With the info from above, we can create the range
            Set rngFile = .Range(.Cells(lngDstFirstFileRow, lngDstLastCol), _
                                 .Cells(lngDstLastRow, lngDstLastCol))
                                
            ''CHECKPOINT: make sure we have correctly identified
            ''the range where our file names will go
            'wksDst.Range("A1").Select
            'rngFile.Select
                                
            'Now that we have that range identified,
            'we write the file name
            rngFile.Value = wbkSrc.Name
            
        End With
        
        'Close the source workbook and repeat
        wbkSrc.Close SaveChanges:=False
        
    Next lngIdx
    
    'Let the user know that the combination is done!
    MsgBox "Data combined!"
    
End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT       : Sheet, the worksheet we'll search to find the last row
'OUTPUT      : Long, the last occupied row
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
    Dim lng As Long
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        With Sheet
            lng = .Cells.Find(What:="*", _
                              After:=.Range("A1"), _
                              Lookat:=xlPart, _
                              LookIn:=xlFormulas, _
                              SearchOrder:=xlByRows, _
                              SearchDirection:=xlPrevious, _
                              MatchCase:=False).Row
        End With
    Else
        lng = 1
    End If
    LastOccupiedRowNum = lng
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT       : Sheet, the worksheet we'll search to find the last column
'OUTPUT      : Long, the last occupied column
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
    Dim lng As Long
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        With Sheet
            lng = .Cells.Find(What:="*", _
                              After:=.Range("A1"), _
                              Lookat:=xlPart, _
                              LookIn:=xlFormulas, _
                              SearchOrder:=xlByColumns, _
                              SearchDirection:=xlPrevious, _
                              MatchCase:=False).Column
        End With
    Else
        lng = 1
    End If
    LastOccupiedColNum = lng
End Function
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
Adding this to the code should work:-
VBA Code:
rngDst.PasteSpecial Paste:=xlPasteAllMergingConditionalFormats
 
Upvote 0
Adding this to the code should work:-
VBA Code:
rngDst.PasteSpecial Paste:=xlPasteAllMergingConditionalFormats
Thank you for the help it is greatly appreciated....If I change it to...
VBA Code:
 rngSrc.Copy Destination:=rngDst '<~ this is the copy / paste
 rngDst.PasteSpecial Paste:=xlPasteAllMergingConditionalFormats
I get a run-time error'1004': Application-defined or object defined error
 
Upvote 0
If you rearrange your original lines slightly it should work.

VBA Code:
        rngSrc.Copy
        rngDst.PasteSpecial Paste:=xlPasteAll
        rngDst.PasteSpecial Paste:=xlPasteFormats
        rngDst.PasteSpecial Paste:=xlPasteValues
 
Upvote 0
Solution
If you rearrange your original lines slightly it should work.

VBA Code:
        rngSrc.Copy
        rngDst.PasteSpecial Paste:=xlPasteAll
        rngDst.PasteSpecial Paste:=xlPasteFormats
        rngDst.PasteSpecial Paste:=xlPasteValues
Dear Alex I still get a run-time error'1004': Application-defined or object defined error??
 
Upvote 0
can you add a line before the copy as follows:
debug.print rngSrc.address(,,,1), rngDst.address(,,,1)

And see if what it prints to the immediate window makes sense.

PS: You can also remove the xlpasteFormats line the PasteAll has this covered.
 
Upvote 0
can you add a line before the copy as follows:
debug.print rngSrc.address(,,,1), rngDst.address(,,,1)

And see if what it prints to the immediate window makes sense.

PS: You can also remove the xlpasteFormats line the PasteAll has this covered.
Hi Alex you are the best it is working perfectly now ....... the problem: there was a "J" character in one of the lines....my fault.
 
Upvote 0

Forum statistics

Threads
1,213,561
Messages
6,114,315
Members
448,564
Latest member
ED38

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