VBA merge excel sheets into new sheet with some conditions

[markwilson]

I'm developing a sample VBA application which will copy the entries from first 3 worksheets (out of 5) and merge them into a new sheet "Master"

Requested help:

Sheet 1 = copy data from G2 until end of rows and paste it into K2 : to end of same sheet
Sheet 2 = no changes.
Sheet 3 = Delete content from K2 : up to end.
after merging first 3 sheets delete all the sheets(tabs) and keep only "Master" Sheet
Please see code below and suggest changes that need to me made.

 Option Explicit[/COLOR]

    Sub CopyFromWorksheets()
    Dim wrk As Workbook  'Workbook object - Always good to work with object variables
    Dim sht As Worksheet 'Object for handling worksheets in loop
    Dim trg As Worksheet 'Master Worksheet
    Dim rng As Range     'Range object
    Dim colCount As Integer 'Column count in tables in the worksheets

    Set wrk = ActiveWorkbook 'Working in active workbook

    For Each sht In wrk.Worksheets
        If sht.Name = "Master" Then
            MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
                    "Please remove or rename this worksheet since 'Master' would be" & _
                    "the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
            Exit Sub
        End If
    Next sht

    'We don't want screen updating
    Application.ScreenUpdating = False

    'Add new worksheet as the last worksheet
    Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
    'Rename the new worksheet
    trg.Name = "Master"
    'Get column headers from the first worksheet
        'Column count first
        Set sht = wrk.Worksheets(1)
        colCount = sht.Cells(1, 255).End(xlToLeft).Column
        'Now retrieve headers, no copy&paste needed
        With trg.Cells(1, 1).Resize(1, colCount)
            .Value = sht.Cells(1, 1).Resize(1, colCount).Value
            'Set font as bold
            .Font.Bold = True
        End With

    'We can start loop
    For Each sht In wrk.Worksheets
        'If worksheet in loop is the last one, stop execution (it is Master worksheet)
        If sht.Index = 4 Then
            Exit For
        End If

        'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
        Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
        'Put data into the Master worksheet
        trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
    Next sht
    'Fit the columns in Master worksheet
    trg.Columns.AutoFit

    'Screen updating should be activated
    Application.ScreenUpdating = True      End Sub

Thanks

[jolivanes]

Is this a start?
Try it on a copy of your workbook until you are certain that it does what you want. With code, gone is gone.

Sub VBAExpress_56881()
    Dim i As Long, lr As Long, lc As Long, ws As Worksheet
    If Not [ISREF(Master!A1)] Then
        Sheets.Add(, Sheets(Sheets.Count)).Name = "Master"
    Else
        Sheets("Master").UsedRange.EntireColumn.Delete
    End If
    With Sheets("Sheet1")
        .Range(.Cells(1, 1), .Cells(1, .UsedRange.Columns.Count)).Copy Sheets("Master").Range("A1")
        .Range("G2:G" & .Cells(.Rows.Count, "G").End(xlUp).Row).Copy .Range("K2")
    End With
    Sheets("Sheet3").Range("K2:K" & Sheets("Sheet3").Cells(Rows.Count, "K").End(xlUp).Row).ClearContents
    For i = 1 To 3
        With Sheets(i)
            lr = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
            lc = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            .Range(.Cells(1, 1), .Cells(lr, lc)).Copy Sheets("Master").Cells(Rows.Count, 1).End(xlUp).Offset(1)
        End With
    Next i
    Application.DisplayAlerts = False
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Master" Then ws.Delete
    Next ws
    Application.DisplayAlerts = True
End Sub

[markwilson]

Thanks for your reply.

This looks bit complicated to me, can i try something simple as copy data from column G2 to last record and paste it into K2 to last in few line of code

thanks again for your response.

[jolivanes]

That's part of the code. In the code it is within the With.....End With statement so it has the periods.

Range("G2:G" & Cells(Rows.Count, "G").End(xlUp).Row).Copy .Range("K2")

[jolivanes]

Re: "This looks bit complicated to me"
How about the code you have in the first post?
Have you tried the code in your workbook? It replaces what you have posted in Post #1

[markwilson]

I'm trying to use below code and its showing error , can you please check

If sht.Index = 1 Then
.Range(.Cells(1, 1), .Cells(1, .UsedRange.Columns.Count)).Copy Sheets("Master").Range("A1")
.Range("G2:G" & .Cells(.Rows.Count, "G").End(xlUp).Row).Copy .Range("K2")
End If

here is the entire code:

Option Explicit


    Sub CopyFromWorksheets()
    Dim wrk As Workbook  'Workbook object - Always good to work with object variables
    Dim sht As Worksheet 'Object for handling worksheets in loop
    Dim trg As Worksheet 'Master Worksheet
    Dim rng As Range     'Range object
    Dim colCount As Integer 'Column count in tables in the worksheets
    Dim FileFullPath As String
    
    Set wrk = ActiveWorkbook 'Working in active workbook
    FileFullPath = ThisWorkbook.FullName
    
    For Each sht In wrk.Worksheets
        If sht.Name = "Master" Then
            MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
                    "Please remove or rename this worksheet since 'Master' would be" & _
                    "the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
            Exit Sub
        End If
    Next sht


     
    If sht.Index = 1 Then
        .Range(.Cells(1, 1), .Cells(1, .UsedRange.Columns.Count)).Copy Sheets("Master").Range("A1")
        .Range("G2:G" & .Cells(.Rows.Count, "G").End(xlUp).Row).Copy .Range("K2")
    End If
    
    'We don't want screen updating
    Application.ScreenUpdating = False


    'Add new worksheet as the last worksheet
    Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
    'Rename the new worksheet
    trg.Name = "Master"
    'Get column headers from the first worksheet
        'Column count first
        Set sht = wrk.Worksheets(1)
        colCount = sht.Cells(1, 255).End(xlToLeft).Column
        'Now retrieve headers, no copy&paste needed
        With trg.Cells(1, 1).Resize(1, colCount)
            .Value = sht.Cells(1, 1).Resize(1, colCount).Value
            'Set font as bold
            .Font.Bold = True
        End With


    Worksheets(3).Columns(11).ClearContents
    'Range("G2:G" & Cells(Rows.Count, "G").End(xlUp).Row).Copy.Range ("K2")
    
    'We can start loop
    For Each sht In wrk.Worksheets
        'If worksheet in loop is the last one, stop execution (it is Master worksheet)
        If sht.Index = 4 Then
            Exit For
        End If
        
        'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
        Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
        
        'Put data into the Master worksheet
        trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
                        
    Next sht
    'Fit the columns in Master worksheet
    trg.Columns.AutoFit
    
    'Delete all the sheet except Master
    Application.DisplayAlerts = False
    For Each sht In Worksheets
    'If sht.Name <> "Master" Then sht.Delete
    Next
    Application.DisplayAlerts = True
        
    'wrk.ActiveWorkbook.SaveAs Filename:=Replace(FileFullPath, ".xls", ".csv", , , vbTextCompare), FileFormat:=xlCSVMSDOS, CreateBackup:=False
    
    'Screen updating should be activated
    Application.ScreenUpdating = True
    End Sub

[jolivanes]

Have you tried the code in Post #2?
That code works.

[markwilson]

could you please help me to integrate your function in my existing code. post # 6 thanks and appreciate your help

[jolivanes]

There is no integrating possible as the code I supplied replaces your code.
Does the code not work?
You can attach a sanitized version of your workbook for us to try.
Is there a particular reason why you need to stick with the code you have that apparently does not work?
There are a few little things that needs to be added yet I think, like "Autofit" column widths but we first need to know if the code does what you asked for in Post #1

[markwilson]

thanks for your reply.

based on my 3 requirement i have completed below one and working code i have attached in the post # 6
Sheet 1 = copy data from G2 until end of rows and paste it into K2 : to end of same sheet (pending)
Sheet 2 = no changes. (done)
Sheet 3 = Delete content from K2 : up to end. ( done)

I dont have ability to attached the code, its just a temp data i have added and wanted to just copy from G2 to G100 = > K2 to K100
(note: here 100 is not a fixed size, it could be anything )

thanks

[jolivanes]

    If Not [ISREF(Master!A1)] Then 
        Sheets.Add(, Sheets(Sheets.Count)).Name = "Master" 
    Else 
        Sheets("Master").UsedRange.EntireColumn.Delete 
    End If

Above checks if you have a sheet named "Master".
If not, it will add a worksheet to the end and name it "Master"
If there is a "Master" sheet, instead of deleting it and adding it again it will
delete all the used columns so you'll have a clean sheet again.

With Sheets("Sheet1") 
        .Range(.Cells(1, 1), .Cells(1, .UsedRange.Columns.Count)).Copy Sheets("Master").Range("A1") 
        .Range("G2:G" & .Cells(.Rows.Count, "G").End(xlUp).Row).Copy .Range("K2") 
    End With

Above copies the first row in Sheet1 to the first row in the "Master" sheet
It also copies from cell G2 to the last used cell in column G in Sheet1 to column K starting at K2

Sheets("Sheet3").Range("K2:K" & Sheets("Sheet3").Cells(Rows.Count, "K").End(xlUp).Row).ClearContents

Above part of the code clears column K, starting at K2, in Sheet3

    For i = 1 To 3 
        With Sheets(i) 
            lr = .Cells.Find("*", , , , xlByRows, xlPrevious).Row 
            lc = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column 
            .Range(.Cells(1, 1), .Cells(lr, lc)).Copy Sheets("Master").Cells(Rows.Count, 1).End(xlUp).Offset(1) 
        End With 
    Next i

This part of the code cycles through the first three sheets and copies cell A1 to the last used row and last
used column and paste it into the "Master" sheet at the first free (=empty) cell in Column A
It does this, as mentioned, for all three sheets

    Application.DisplayAlerts = False 
    For Each ws In ActiveWorkbook.Worksheets 
        If ws.Name <> "Master" Then ws.Delete 
    Next ws 
    Application.DisplayAlerts = True

This part deletes all sheets except a sheet called "Master"
The "DisplayAlerts" statement is to avoid getting the popup asking if it is OK to delete the sheet with data in it.

Re: Your Post #6

        .Range(.Cells(1, 1), .Cells(1, .UsedRange.Columns.Count)).Copy Sheets("Master").Range("A1") 
        .Range("G2:G" & .Cells(.Rows.Count, "G").End(xlUp).Row).Copy .Range("K2")

These two lines need to be between "With" and "End With" because of the preceding periods (.)
VBA knows that anything starting with a period is a property or a method of the object following the With
http://www.java2s.com/Code/VBA-Excel...ingtheWith.htm
http://www.homeandlearn.org/with_end_with.html
http://www.quepublishing.com/article...21718&seqNum=5
Example:
If you are in any sheet but not Sheet1 and run the following

With Sheets("Sheet1")
'some code here
.Range("A1:A10").Interior.Color = vbRed    '<----- has preceding period
End With

it will color that range in Sheet1 to red.

With Sheets("Sheet1")
'some code here
Range("A1:A10").Interior.Color = vbRed    '<----- no preceding period
End With

this will color the range of the sheet you are in to red, not in Sheet1


Still waiting on answers for the questions in Post #9

[markwilson]

looks good ... it works for me..


just want to add few suggestion.
1. we have 3 worksheet and everytime while copying the data from every sheet its also including the header as well
can we add a validation that not to include header part (1 Rows)


2. I'm seeing in few column data is not displaying correctly its showing something #REF! ( I have lookup on other sheet )
can we generate a report including that column value than #ref (null)


thanks again for your support and good stuff

[markwilson]

Sorry for the duplicate post .. I have deleted it..

[jolivanes]

Re #1. No problem. For all three sheets?
Re #2. Formulas in all three sheets?

[markwilson]

Point #1 - Yes
Point # 2- Yes, we have formulas in all 3 sheets . Thanks ||

[jolivanes]

Try this on a copy of your workbook

Sub VBAExpress_56881()
    Dim i As Long, lr As Long, lc As Long, ws As Worksheet
    Application.ScreenUpdating = False
    If Not [ISREF(Master!A1)] Then
        Sheets.Add(, Sheets(Sheets.Count)).Name = "Master"
    Else
        Sheets("Master").UsedRange.EntireColumn.Delete
    End If
    With Sheets("Sheet1")
        .Range(.Cells(1, 1), .Cells(1, .UsedRange.Columns.Count)).Copy Sheets("Master").Range("A1")
        .Range("G2:G" & .Cells(.Rows.Count, "G").End(xlUp).Row).Copy .Range("K2")
    End With
    Sheets("Sheet3").Range("K2:K" & Sheets("Sheet3").Cells(Rows.Count, "K").End(xlUp).Row).ClearContents
    For i = 1 To 3
        With Sheets(i)
            lr = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
            lc = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            Sheets("Master").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(lr - 1, lc).Value = .Range(.Cells(2, 1), .Cells(lr, lc)).Value
        End With
    Next i
    Application.DisplayAlerts = False
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Master" Then ws.Delete
    Next ws
    Application.DisplayAlerts = True
    Sheets("Master").UsedRange.Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

[markwilson]

Awesome .. it works for me

one small help .. I have time column in all 3 workbook and there format looks like - h:mm AM/PM type.. how i can for all "I" column
currently - after executing VBA application records are showing like this -0.791666666666667 than 10.40 PM Thanks

[jolivanes]

Replace the 3rd line from the end

Sheets("Master").UsedRange.Columns.AutoFit

with these 4 lines

With Sheets("Master")
.Range("I1:I" & .Cells(.Rows.Count, 9).End(xlUp).Row).NumberFormat = "hh:mm AM/PM"
.UsedRange.Columns.AutoFit
End With

[markwilson]

Cool , its Done...

-- How i can mark this post as an answer and is there any way where i can give you reputation as well .

[jolivanes]

Glad you got it working the way you want it.
Good luck

Really appreciate the reputation, I think you have to click on the little black star at the bottom left corner.

If your problem has been solved in your thread, mark the thread "Solved" by going to the "Thread Tools" dropdown at the top of the thread.