VBA Macro to copy entire row to another sheet

[leopard]

Hi All,

I have written Macro to copy every row in "sheet1" 24 times into new sheet called "NewSheet". but it keep giving me error message. Actually, I don't know why. Can any one please help.

here is my macro

Sub CopyRowsBook2()

Worksheets.Add().Name = "NewSheet"
Sheets("Sheet1").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row

' Loop through each row
For x = 2 To FinalRow
Worksheets("sheet1").Cells(x, 1).Select
ActiveCell.EntireRow.Select
Selection.Copy
' Loop to copy every row 24 times
For i = 1 To 24

Sheets("NewSheet").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste

Next i

Sheets("Sheet1").Select


Next x
End Sub


Thanks in advance,

 

[leopard]

thats good idea,
it errors in next line

ActiveSheet.Paste

 

[GTO]

Okay, I have to get going pretty quick, but lets try some specifics:

Does it error in the first time thru the loop, or make it for several rows then error?
Is the data in the cells just data, or is there an object that ends up getting copied?
Is the data in the cells actual values, or are there formulas in the cells?

Finally - when you are copying (lets say you did it manually), are you looking to take just the data, or, are you wanting to copy formatting such as borders, fonts, etc?

Sorry I am not being a better help. I tossed some random values on sheet1 and just don't see where something could fall down...

Mark

 

[leopard]

It errors in the first time thru the loop
rows are data there is no formula and i'm looking to copy these data doesnt matter the font and other formatting

 

[GTO]

Here you go. In a copy of your wb, try:

Option Explicit
 
Sub exa()
Dim _
wksSource           As Worksheet, _
wksDest             As Worksheet, _
rngLastColOrRow     As Range, _
rngSourceColA       As Range, _
rngDestCell         As Range, _
rngSourceCell       As Range, _
rngLastColSource    As Range, _
lLColSource         As Long, _
i                   As Long, _
aryVals             As Variant
 
    '// Set a reference to both sheets                                                  //
    Set wksSource = ThisWorkbook.Worksheets("Sheet1")
    Set wksDest = ThisWorkbook.Worksheets("Sheet2")
 
 
    With wksSource
        '// Attempt to find the last row with any data in the source sheet, from A2 to  //
        '// the bottom/right-most cell.                                                 //
        Set rngLastColOrRow = RangeFound(Range(.Range("A2"), .Cells(Rows.Count, Columns.Count)))
        '// In case nothing found, bail...                                              //
        If rngLastColOrRow Is Nothing Then
            MsgBox "No vals in Source", 0, vbNullString
            Exit Sub
        End If
        '// else...
        '// Set our range for the source, just using Col A                              //
        Set rngSourceColA = Range(.Range("A2"), .Cells(rngLastColOrRow.Row, 1))
 
        '// Find the last column with any data in it in source sheet, so our arrays     //
        '// are not unnecessarily big.                                                  //
        Set rngLastColSource = RangeFound(Range(.Range("A2"), .Cells(Rows.Count, Columns.Count)), , , , , xlByColumns)
 
        lLColSource = rngLastColSource.Column
    End With
 
    '// Loop thru the first column in our source range...                               //
    For Each rngSourceCell In rngSourceColA
 
        '// Assign the vals in the row to an array...                                   //
        aryVals = rngSourceCell.Resize(, lLColSource).Value
 
        '// Assign (if first loop and Dest sheet is empty) our initial row or Find      //
        '// the row last filled in Dest sheet...                                        //
        Set rngLastColOrRow = RangeFound(Range(wksDest.Range("A2"), wksDest.Cells(Rows.Count, Columns.Count)))
        If rngLastColOrRow Is Nothing Then
            Set rngDestCell = wksDest.Range("A1")
        Else
            Set rngDestCell = wksDest.Cells(rngLastColOrRow.Row, 1)
        End If
 
        '//...then plunk the array in the next 24 rows.                                 //
        For i = 1 To 24
            rngDestCell.Resize(, lLColSource).Offset(i).Value = aryVals
        Next
    '// Rinse and repeat...//
    Next
End Sub
 
Function RangeFound(SearchRange As Range, _
                    Optional FindWhat As String = "*", _
                    Optional StartingAfter As Range, _
                    Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
                    Optional LookAtWholeOrPart As XlLookAt = xlPart, _
                    Optional SearchRowCol As XlSearchOrder = xlByRows, _
                    Optional SearchUpDn As XlSearchDirection = xlPrevious, _
                    Optional bMatchCase As Boolean = False) As Range
 
    If StartingAfter Is Nothing Then
        Set StartingAfter = SearchRange(1)
    End If
 
    Set RangeFound = SearchRange.Find(What:=FindWhat, _
                                      After:=StartingAfter, _
                                      LookIn:=LookAtTextOrFormula, _
                                      LookAt:=LookAtWholeOrPart, _
                                      SearchOrder:=SearchRowCol, _
                                      SearchDirection:=SearchUpDn, _
                                      MatchCase:=bMatchCase)
End Function

Hope that helps,

Mark

 

[leopard]

thank you so much for your help, I appreciate that.

 

[GTO]

Happy to help