|  

» Copy from row till the last row with data into one sheet using VBA in Microsoft Excel

VBA macro tip contributed by Ron de Bruin, Microsoft MVP - Excel
  • The macro will add a sheet with the name Master to your workbook and will copy the cells from every sheet in your workbook in this worksheet.
  • The first macro does a normal copy and the second macro copy the Values.
  • The macro's subs use the functions below, the macro's won’t work without the functions.

Sub CopyFromRow()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim shLast As Long
    Dim Last As Long
    If SheetExists("Master") = True Then
        MsgBox "The sheet Master already exist"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Set DestSh = Worksheets.Add
    DestSh.Name = "Master"
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then
            If sh.UsedRange.Count > 1 Then
                Last = LastRow(DestSh)
                shLast = LastRow(sh)
                sh.Range(sh.Rows(3), sh.Rows(shLast)).Copy DestSh.Cells(Last + 1, 1)
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Sub CopyFromRowValues()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim shLast As Long
    Dim Last As Long
    If SheetExists("Master") = True Then
        MsgBox "The sheet Master already exist"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Set DestSh = Worksheets.Add
    DestSh.Name = "Master"
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then
            If sh.UsedRange.Count > 1 Then
                Last = LastRow(DestSh)
                shLast = LastRow(sh)
                With sh.Range(sh.Rows(3), sh.Rows(shLast))
                    DestSh.Cells(Last + 1, 1).Resize(.Rows.Count, _
                    .Columns.Count).Value = .Value
                End With
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub



Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

Function Lastcol(sh As Worksheet)
    On Error Resume Next
    Lastcol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function
Function SheetExists(SName As String, _
                     Optional ByVal WB As Workbook) As Boolean
     On Error Resume Next
    If WB Is Nothing Then Set WB = ThisWorkbook
    SheetExists = CBool(Len(Sheets(SName).Name))
End Function


Rate This Tip
12 34 5
Rating: 4.17     Views: 34713
No comments have been submitted.
Click here to post comment
For Registered Users
Name
Comment Title
Comments