如何使用Excel VBA将几张矩阵数据转换为另一张纸上跳过零值的单一数据库格式

Question

我有几张纸，其中包含标准化矩阵格式的检索，每张纸都有几个静态数据列和几个值列。在文件中，我放了两个具有这种标准化格式的选项卡的示例，然后放了一个具有数据库格式的输出选项卡。

在完整的文件中，每个矩阵表中都有更多的静态数据和值列，因此宏在这方面需要非常灵活。

我也希望宏跳过值列中所有为零的条目。我试图四处看看，但是我对VBA还是很陌生，所以很难将一些可行的方法组合在一起...

有人可以帮忙吗？

https://www.dropbox.com/s/eh1mr0nin51354j/Multiple%20Sheet%20Database%20Creation.xlsx?dl=0

Answer 1

看来您想将多张工作表中的所有内容合并到一个'MasterSheet'中，对。尝试下面的代码，看看它是否满足您的要求。

Sub CopyDataWithoutHeaders()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim shLast As Long
    Dim CopyRng As Range
    Dim StartRow As Long

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Delete the sheet "RDBMergeSheet" if it exist
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'Add a worksheet with the name "RDBMergeSheet"
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "RDBMergeSheet"

    'Fill in the start row
    StartRow = 1

    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then

            'Find the last row with data on the DestSh and sh
            Last = LastRow(DestSh)
            shLast = LastRow(sh)

            'If sh is not empty and if the last row >= StartRow copy the CopyRng
            If shLast > 0 And shLast >= StartRow Then

                'Set the range that you want to copy
                Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))

                'Test if there enough rows in the DestSh to copy all the data
                If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                    MsgBox "There are not enough rows in the Destsh"
                    GoTo ExitTheSub
                End If

                'This example copies values/formats, if you only want to copy the
                'values or want to copy everything look below example 1 on this page
                CopyRng.Copy
                With DestSh.Cells(Last + 1, "A")
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With

            End If

        End If
    Next

ExitTheSub:

    Application.Goto DestSh.Cells(1)

    'AutoFit the column width in the DestSh sheet
    DestSh.Columns.AutoFit

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
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

之前（3张，看起来像这样）：

之后：

https://www.rondebruin.nl/win/s3/win002.htm

最后，您要删除所有为0的内容，对。一栏是零，还是所有栏都删除零？

要删除ColumnA中具有零的行：

Sub DeleteRow()
Dim r As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  For r = LastRow To 1 Step -1
    If Cells(r, "A") = 0 Then
      Rows(r).Delete
    End If
  Next r
End Sub

如果前20列中的所有记录均为零，则删除一行：

Sub DeleteRowsZeros()
Dim rw As Long, i As Long
rw = Cells(Rows.Count, 1).End(xlUp).row
    For i = rw To 1 Step -1
    If Application.Sum(Cells(rw, 1).Resize(1, 20)) = 0 Then
        Rows(rw).Delete
    End If
    rw = rw - 1
Next
End Sub