Combine Few Sheets to one summary

[joycesolomon]

Hi

I found the below code and it works great:

[COLOR=blue]Sub[/COLOR] CopyFromWorksheets() 
    [COLOR=blue]Dim[/COLOR] wrk [COLOR=blue]As[/COLOR] Workbook [COLOR=darkgreen]'Workbook object - Always good to work with object variables[/COLOR]
    [COLOR=blue]Dim[/COLOR] sht [COLOR=blue]As[/COLOR] Worksheet [COLOR=darkgreen]'Object for handling worksheets in loop[/COLOR]
    [COLOR=blue]Dim[/COLOR] trg [COLOR=blue]As[/COLOR] Worksheet [COLOR=darkgreen]'Master Worksheet[/COLOR]
    [COLOR=blue]Dim[/COLOR] rng [COLOR=blue]As[/COLOR] Range [COLOR=darkgreen]'Range object[/COLOR]
    [COLOR=blue]Dim[/COLOR] colCount [COLOR=blue]As[/COLOR] [COLOR=blue]Integer[/COLOR] [COLOR=darkgreen]'Column count in tables in the worksheets[/COLOR]
     
    [COLOR=blue]Set[/COLOR] wrk = ActiveWorkbook [COLOR=darkgreen]'Working in active workbook[/COLOR]
     
    [COLOR=blue]For Each[/COLOR] sht [COLOR=blue]In[/COLOR] wrk.Worksheets 
        [COLOR=blue]If[/COLOR] sht.Name = "Master" [COLOR=blue]Then[/COLOR] 
            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 [COLOR=blue]Sub[/COLOR] 
        [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR] 
    [COLOR=blue]Next[/COLOR] sht 
     
     [COLOR=darkgreen]'We don't want screen updating[/COLOR]
    Application.ScreenUpdating = [COLOR=blue]False[/COLOR] 
     
     [COLOR=darkgreen]'Add new worksheet as the last worksheet[/COLOR]
    [COLOR=blue]Set[/COLOR] trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count)) 
     [COLOR=darkgreen]'Rename the new worksheet[/COLOR]
    trg.Name = "Master" 
     [COLOR=darkgreen]'Get column headers from the first worksheet[/COLOR]
     [COLOR=darkgreen]'Column count first[/COLOR]
    [COLOR=blue]Set[/COLOR] sht = wrk.Worksheets(1) 
    colCount = sht.Cells(1, 255).End(xlToLeft).Column 
     [COLOR=darkgreen]'Now retrieve headers, no copy&paste needed[/COLOR]
    [COLOR=blue]With[/COLOR] trg.Cells(1, 1).Resize(1, colCount) 
        .Value = sht.Cells(1, 1).Resize(1, colCount).Value 
         [COLOR=darkgreen]'Set font as bold[/COLOR]
        .Font.Bold = [COLOR=blue]True[/COLOR] 
    [COLOR=blue]End With[/COLOR] 
     
     [COLOR=darkgreen]'We can start loop[/COLOR]
    [COLOR=blue]For Each[/COLOR] sht [COLOR=blue]In[/COLOR] wrk.Worksheets 
         [COLOR=darkgreen]'If worksheet in loop is the last one, stop execution (it is Master worksheet)[/COLOR]
        [COLOR=blue]If[/COLOR] sht.Index = wrk.Worksheets.Count [COLOR=blue]Then[/COLOR] 
            Exit [COLOR=blue]For[/COLOR] 
        [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR] 
         [COLOR=darkgreen]'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets[/COLOR]
        [COLOR=blue]Set[/COLOR] rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount)) 
         [COLOR=darkgreen]'Put data into the Master worksheet[/COLOR]
        trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value 
    [COLOR=blue]Next[/COLOR] sht 
     [COLOR=darkgreen]'Fit the columns in Master worksheet[/COLOR]
    trg.Columns.AutoFit 
     
     [COLOR=darkgreen]'Screen updating should be activated[/COLOR]
    Application.ScreenUpdating = [COLOR=blue]True[/COLOR] 
[COLOR=blue]End Sub[/COLOR]

But this code copies from all the available sheets. I only want it to copy from sheet named 1 to 100. Can someone show me how to improve this code for that purpose?

Thanks

 

[joycesolomon]

i did not know, i closed the thread the other site....

But for this code, i found the error and managed it, and it works great!

Thank you and thank you again!!!!

 

[Joe4]

Great, glad you got it to work out!