PDA

View Full Version : [SOLVED] VBA merge excel sheets into new sheet with some conditions



markwilson
08-15-2016, 11:28 AM
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
08-16-2016, 09:35 AM
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
08-16-2016, 07:36 PM
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
08-16-2016, 08:28 PM
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
08-16-2016, 08:40 PM
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
08-17-2016, 07:26 AM
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
08-17-2016, 09:08 AM
Have you tried the code in Post #2?
That code works.

markwilson
08-17-2016, 07:40 PM
could you please help me to integrate your function in my existing code. post # 6 thanks and appreciate your help

jolivanes
08-17-2016, 08:54 PM
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
08-17-2016, 09:07 PM
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
08-17-2016, 10:32 PM
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-Access-Word/Data-Type/VBAknowsthatanythingstartingwithaperiodisapropertyoramethodoftheobjectfollo wingtheWith.htm
http://www.homeandlearn.org/with_end_with.html
http://www.quepublishing.com/articles/article.aspx?p=2021718&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
08-18-2016, 07:26 AM
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
08-18-2016, 07:41 AM
Sorry for the duplicate post .. I have deleted it..

jolivanes
08-18-2016, 09:10 AM
Re #1. No problem. For all three sheets?
Re #2. Formulas in all three sheets?

markwilson
08-18-2016, 09:13 AM
Point #1 - Yes
Point # 2- Yes, we have formulas in all 3 sheets . Thanks ||

jolivanes
08-18-2016, 09:35 AM
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
08-18-2016, 12:25 PM
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
08-18-2016, 02:48 PM
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
08-18-2016, 05:17 PM
Cool , its Done... :thumb:thumb:thumb

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

jolivanes
08-18-2016, 06:58 PM
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.

markwilson
09-08-2016, 08:12 AM
Hey

i know this was resolved but want to check if i can add sorting in the existing code.
I want to sort entire spreadsheet by column name I & J (column's are - appointment date) . I have total A-> P column in the workbook

Here is the sort criteria , could you please guide me on how to configure through VBA code.

17050