Копировать данные из нескольких строк, только если данные существуют

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 (представляет Sheet 2) и т. Д. И позволит мне вставьте в следующую доступную строку в другой книге.

Вот код, который работает для одной строки данных.

Код VBA:

Sub CopyDataSheet()
'
' CopyDataSheet Macro

'
Application.ScreenUpdating = False
Sheets("Data Sheet").Visible = True


Sheets("Data Sheet").Select
Rows("3:3").Select
Selection.Copy
Rows("1:1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("E1:EF1").Select
Application.CutCopyMode = False
Selection.NumberFormat = "0"
Rows("1:1").Select
Range("B1").Activate
Selection.Copy
Sheets("Sheet 1").Select
Range("a38").Select

Sheets("Data Sheet").Visible = True

Application.ScreenUpdating = True

  MsgBox "YOU HAVE CAPTURED ALL ENTERED DATA..." & _
vbCrLf & vbCrLf & "CLICK OK" _
& vbCrLf & vbCrLf & "PASTE INTO NEXT EMPTY LINE OF DATA SHEET", _
    vbInformation, ""
End Sub

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 = Range ("A" & 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