Copia dalla riga fino all'ultima riga con i dati in un foglio utilizzando VBA in Microsoft Excel

Anonim
  • La macro aggiungerà un foglio con il nome Master alla cartella di lavoro e copierà le celle da ogni foglio della cartella di lavoro in questo foglio di lavoro.
  • La prima macro esegue una copia normale e la seconda macro copia i valori.
  • I sottotitoli della macro utilizzano le funzioni seguenti, le macro non funzioneranno senza le funzioni.
Sub CopyFromRow() Dim sh As Worksheet Dim DestSh As Worksheet Dim shLast As Long Dim Last As Long If SheetExists("Master") = True Then MsgBox "Il foglio principale esiste già" Exit Sub End If Application.ScreenUpdating = False Imposta DestSh = Worksheets.Add DestSh.Name = "Master" per ogni 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 CopyFromRowValues() Dim sh As Worksheet Dim DestSh As Worksheet Dim shLast As Long Dim Last As Long If SheetExists("Master") = True Then MsgBox "Il foglio principale esiste già" 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 Funzione 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 Riprendi in seguito se WB non è nulla Quindi imposta WB = ThisWorkbook SheetExists = CBool(Len(Sheets(SName).Name)) End Function