Question

我有一个名为Data Sheet的电子表格，可以通过公式从其他工作表中收集数据并且工作正常。我需要一个宏来复制多行数据，这样我就可以粘贴到一个单独的工作簿中。

我有30行数据，范围从A3:EI3到A32:EI32。如果这些数据可见并输入数据，则从1到30张其他纸张中收集这些数据。这是棘手的部分：我只想收集可见表中的数据。

以下是我正在寻找的流程示例：Sheet 1始终可见，永远不会被隐藏。 Sheet 2，Sheet 3和Sheet 4可见，但Sheet 5到Sheet 30仍然隐藏。 Data Sheet已经从可见工作表中收集了数据，但其余行（表5-30）都在数据单元格中显示0。

我现在想要运行一个宏，它将从Data Sheet Row 3（代表Sheet 1），Row 4复制数据（到剪贴板），代表{{1 }等等，并允许我粘贴到另一个工作簿中的下一个可用行。

以下是适用于单行数据的代码。

VBA代码：

Sheet 2

Answer 1

我不是100％确定你想要做什么，但我想我可以提供一些可能对你有用的代码片段。

这将循环显示活动工作簿中的工作表，并允许您根据工作表是否可见来执行某些操作：

j = ActiveWorkbook.Sheets.Count

For i = 1 To j
  Select Case Sheets(i).Visible
    Case xlSheetVisible
      'Do something if the sheet is visible
    Case Else
      'Do something when the sheet is not visible
  End Select
Next i

要获得下一个可用行，有许多不同的方法。其中最简单的就是：

next_row =范围（“A”＆amp; Rows.Count）.End（xlUp）.row + 1

这假设列A在任何数据行中始终具有值。如果不是这种情况，您可以尝试这样做：

next_row = ActiveSheet.UsedRange.Rows.Count + 1

既不是防弹，但它至少应该给你一个开始。

Answer 2

Option Explicit

Public Sub CollectData()
    Dim wsCrnt As Excel.Worksheet
    Dim wsDest As Excel.Worksheet
    Dim lRowCrnt As Long
    Dim lRowDest As Long
    On Error GoTo Err_Hnd
    ToggleInterface False
    Set wsDest = ThisWorkbook.Worksheets("Data Sheet")
    lRowDest = wsDest.UsedRange.Rows.Count + 1&
    For Each wsCrnt In ThisWorkbook.Worksheets
        If wsCrnt.Visible = xlSheetVisible Then
            If Not wsCrnt Is wsDest Then
                For lRowCrnt = 1& To 30&
                    If Excel.WorksheetFunction.CountA(wsCrnt.Rows(lRowCrnt)) Then
                        wsCrnt.Rows(lRowCrnt).Copy
                        wsDest.Rows(lRowDest).PasteSpecial xlPasteValues
                        lRowDest = lRowDest + 1
                    End If
                Next
            End If
        End If
    Next
Exit_Proc:
    On Error Resume Next
    ToggleInterface True
    Exit Sub
Err_Hnd:
    MsgBox Err.Description, vbCritical Or vbMsgBoxHelpButton, _
        "Error: " & Err.Number, Err.HelpFile, Err.HelpContext
    Resume Exit_Proc
End Sub

Private Sub ToggleInterface(ByVal interfaceOn As Boolean)
    With Excel.Application
        .Cursor = IIf(interfaceOn, xlDefault, xlWait)
        .StatusBar = IIf(interfaceOn, False, "Working...")
        .EnableEvents = interfaceOn
        .Calculation = IIf(interfaceOn, xlCalculationAutomatic, xlCalculationManual)
        .ScreenUpdating = interfaceOn
        .EnableCancelKey = Abs(interfaceOn)
    End With
End Sub

仅在数据存在时才从多行复制数据

2 个答案: