Dear Andy,
                Try the following code.

Public Sub CombineWorksheets()
'
'   This routine assumes that ALL worksheets have the same field structure;
'   same column headings, and the same column order. The code copies all
'   rows into a new worksheet called "Combined".
'

    Dim wrk As Workbook         ' Workbook object
    Dim sht As Worksheet        ' Object for handling worksheets in loop
    Dim trg As Worksheet        ' Combined 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 = "Combined" Then
            MsgBox "There is already a worksheet named 'Combined'." & vbCrLf & _
            "Please remove or rename this worksheet.", vbOKOnly + 
vbExclamation, "Error"
            Exit Sub
        End If
    Next sht
    
    Application.ScreenUpdating = False   ' Disable screen updating
     
    ' Add "Combined" worksheet as the last worksheet
    Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
    trg.Name = "Combined"
    
     ' Get column headers from the first worksheet
     
    Set sht = wrk.Worksheets(1)                  ' Get Column count
    colCount = sht.Cells(1, 255).End(xlToLeft).Column
      
    With trg.Cells(1, 1).Resize(1, colCount)     ' retrieve headers
        .Value = sht.Cells(1, 1).Resize(1, colCount).Value
        .Font.Bold = True
    End With
     
    For Each sht In wrk.Worksheets
    
        ' If this worksheet is the last one, stop execution
        If sht.Index = wrk.Worksheets.Count Then
            Exit For
        End If
        
        ' Data range begins with second row
        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
    
    trg.Columns.AutoFit     ' Fit the columns in Master worksheet
     
    Application.ScreenUpdating = True   '  Enable screen updating
End Sub



Thanks & regards,

|| Mudassar Ramzan | MIS Officer | WorldCALL Telecom Ltd | 061- 814-3999 | 0321 
7325277 ||





  ----- Original Message ----- 
  From: Aindril De 
  To: excel-macros@googlegroups.com 
  Sent: Thursday, April 02, 2009 8:02 PM
  Subject: $$Excel-Macros$$ Re: Help with Nested For Loop


  Hi Sathish,

  Thanks a lot for the help.

  This shd work with the name of the sheets like Sheet1 Sheet2 etc and that too 
if the names are missing like for e.g Sheet3 is missing and you have Sheet 4 
after Sheet 2 then it will not work correctly... 
  However what I want is any name of the sheet can make the code work. and also 
it shd copy the first header row from the first sheet.

  Hope it explains the problem more.

  regards,
  Andy


  On Thu, Apr 2, 2009 at 4:25 PM, Aindril De <aind...@gmail.com> wrote:

    Hi All,

    I am trying to write a Macro to do the following:

    It will Count the number of sheets in the workbook and then copy the 
contents of all the sheets into a sheet called "Results". Following is the code 
that I have written. But the problem is the Nested For Loop is not working. 
Once it enters in the inner loop, it never comes out of the innet loop and 
hence the macro execution ends.

    Sub copyRows_1()
    Dim SiteCol As Range, Cell As Object, SheetCount As Long, m As Long
    Application.Volatile
    SheetCount = Sheets.Count
    For m = 1 To SheetCount - 1
    Sheets(m).Activate
    MsgBox "Copying From Sheet " & ActiveSheet.Name
    Set SiteCol = Range("A1:A700")
    For Each Cell In SiteCol
    If IsEmpty(Cell) Then
    Exit Sub
    End If
    Cell.EntireRow.Copy
    Sheets("Results").Activate
    ActiveSheet.Range("A65536").End(xlUp).Select
    Selection.Offset(1, 0).Select
    ActiveSheet.Paste
    Next Cell
    Next m
    End Sub

    Need help in arranging the FOR loop properly!

    Thanks in Advance
    Andy 






  


--~--~---------~--~----~------------~-------~--~----~
-------------------------------------------------------------------------------------
Some important links for excel users:
1. Excel and VBA Tutorials(Video and Text), Free add-ins downloads at 
http://www.excelitems.com
2. Excel tutorials at http://www.excel-macros.blogspot.com
3. Learn VBA Macros at http://www.vbamacros.blogspot.com
4. Excel Tips and Tricks at http://exceldailytip.blogspot.com
 

To post to this group, send email to excel-macros@googlegroups.com
If you find any spam message in the group, please send an email to:
Ayush Jain  @ jainayus...@gmail.com or
Ashish Jain @ 26may.1...@gmail.com
-------------------------------------------------------------------------------------
-~----------~----~----~----~------~----~------~--~---

Reply via email to