Kopieren Sie von Zeile bis letzte Zeile mit Daten in ein Blatt mit VBA in Microsoft Excel

Anonim
  • Das Makro fügt Ihrer Arbeitsmappe ein Blatt mit dem Namen Master hinzu und kopiert die Zellen aus jedem Blatt in Ihrer Arbeitsmappe in dieses Arbeitsblatt.
  • Das erste Makro macht eine normale Kopie und das zweite Makro kopiert die Werte.
  • Die Subs des Makros verwenden die folgenden Funktionen, die Makros funktionieren nicht ohne die Funktionen.
Sub CopyFromRow() Dim sh As Worksheet Dim DestSh As Worksheet Dim shLast As Long Dim Last As Long If SheetExists("Master") = True Then MsgBox "Der Blattmaster existiert bereits" Exit Sub End If Application.ScreenUpdating = False Set DestSh = Worksheets.Add DestSh.Name = "Master" For Every 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 "Der Blattmaster existiert bereits" 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 If Next Application.ScreenUpdating = True End Sub Funktion 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