数组数组专长。 3维锯齿阵列

Question

我一直试图做一个报告，并创建一个宏来将数据从一个文件复制到另一个文件。

我无法弄清楚如何复制数据，因为我需要从中获取数据的表各不相同。

示例一：

Example one

我需要复制的是“警报”文本下方的内容。

但是在示例一中，我没有严重警报，但是可能有文件。同样适用于主要/次要/警告。

“警报”文本下方的最大行数为3，但我可以为1/2/3，甚至没有。

Example 2

在示例2中，我没有数据。

Example 3

在这里，我在所有其他类别中都具有2个关键点和3个。

我知道这可能是一个奇怪的问题，但是我不知道如何找到这些值，因为它们可能相差很大。

感谢所有帮助

这是我的代码，但我缺少重要的部分，

          Sub Copy()



Dim wbOpen As Workbook
Dim wbMe As Workbook
Dim vals As Variant

Set wbMe = ThisWorkbook
Set wbOpen = Workbooks.Open("C:\XXX\Core")

'MSS

     vals = wbOpen.Sheets("MSS02NZF").Range("A2:B260").Copy
wbMe.Sheets("MSS02NZF").Range("B5").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
                 Operation:=xlNone, SkipBlanks:=False, Transpose:=False


       '  wbOpen.Sheets(1).Range("A2:B260").Copy
   ' wbMe.Sheets(1).Range("B5").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
                 Operation:=xlNone, SkipBlanks:=False, Transpose:=False

     'MME
  vals = wbOpen.Sheets("MME01NZF").Range("A2:H260").Copy
wbMe.Sheets("MME01NZF").Range("B5").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
                 Operation:=xlNone, SkipBlanks:=False, Transpose:=False


                     'CSCF
  vals = wbOpen.Sheets("CSCF").Range("A2:H2060").Copy
wbMe.Sheets("CSCF").Range("B5").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
                 Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Answer 1

根据自己的需要进行修改；代码使用A：B作为源，并将结果粘贴到C：D。

Sub test()
    Dim lrow As Long, alarmRow() As Long, alarmEnd() As Long
    Dim count As Long, count2 As Long, rowcount As Long

    ReDim alarmRow(1 To Application.CountIf(Range("A:A"), "Alarm"))
    ReDim alarmEnd(1 To UBound(alarmRow))

    With Worksheets("Sheet4") 'Change this to the Sheetname of your source.
        lrow = .Cells(Rows.count, 1).End(xlUp).Row
        For x = 1 To lrow Step 1
            If .Range("A" & x).Value = "Alarm" Then 'Change "A" column to where your source data is.
                count = count + 1
                alarmRow(count) = x + 1
            ElseIf .Range("A" & x).Value = "" Then 'Change "A" column to where your source data is.

                count2 = count2 + 1
                alarmEnd(count2) = x
            End If
            alarmEnd(UBound(alarmEnd)) = lrow
        Next

        For x = 1 To UBound(alarmRow) Step 1
            lrow = .Cells(Rows.count, 3).End(xlUp).Row + 1
            rowcount = alarmEnd(x) - alarmRow(x)
            .Range("C" & lrow & ":D" & lrow + rowcount).Value = .Range("A" & alarmRow(x) & ":B" & alarmEnd(x)).Value ' Change A/B to where your source data is, and C/D to where you want to put the list.
        Next
    End With
End Sub

有点混乱，但是它是这样工作的：它将查看单词“ Alarm”所在的列表。一旦找到它，单词所在的行号就会注册到一个数组中。空白行也被带到另一个数组。这将用作复制数据时的范围。

Answer 2

数组数组专长。 3维锯齿阵列

Option Explicit

'*******************************************************************************
' Purpose:  If not open, opens a specified workbook and pastes specific data
'           found in two columns from several worksheets into a range specified
'           by a cell in worksheets with the same name in this workbook.
'*******************************************************************************
Sub CopyPasteArray()
'***************************************
  ' List of Worksheet Names in Both Workbooks
  Const cStrWsName As String = "MSS02NZF,MME01NZF,CSCF"
  ' Separator in List of Names of Worksheets in Both Workbooks
  Const cStrSplit As String = ","
  ' Path of Workbook to Be Copied From
  Const cStrSourcePath As String = "C:\XXX"
  ' Name of Workbook to Be Copied From
  Const cStrSourceName As String = "Core.xls"
  ' Address of First Row Range to Be Copied From
  Const cStrSourceFirst As String = "A2:B2"
  ' Target Top Cell Address to Be Pasted Into
  Const cStrTopCell As String = "B5"
  ' Search String
  Const cStrSearch As String = "Alarm"
  ' Target Columns
  Const cIntTargetCols As Integer = 2 ' Change to 3 to include Type of Error.

'***************************************
  Dim objWbSource As Workbook         ' Source Workbook

  Dim vntWsName As Variant            ' Worksheet Names Array
  Dim vntSourceAA As Variant          ' Source Array of Arrays
  Dim vntTargetAA As Variant          ' Target Array of Arrays
  Dim vntTargetRows As Variant        ' Each Target Array Rows Array
  Dim vntTarget As Variant            ' Each Target Array

  Dim blnFound As Boolean             ' Source Workbook Open Checker
  Dim lngRow As Long                  ' Source Array Arrays Rows Counter
  Dim intCol As Integer               ' Source Array Arrays Columns Counter
  Dim intArr As Integer               ' Worksheets and Arrays Counter
  Dim lngCount As Long                ' Critical Data Counter
  Dim lngCount2 As Long               ' Critical Data Next Row Counter
  Dim strPasteCell As String

'***************************************
  ' Paste list of worksheets names into Worksheet Names Array.
  vntWsName = Split(cStrWsName, cStrSplit)

'***************************************
  ' Check if Source Workbook is open.
  For Each objWbSource In Workbooks
    If objWbSource.Name = cStrSourceName Then
      Set objWbSource = Workbooks(cStrSourceName)
      blnFound = True ' Workbook is open.
      Exit For        ' Stop checking.
    End If
  Next
  ' If Source Workbook is not open, open it.
  If blnFound = False Then
    Set objWbSource = Workbooks.Open(cStrSourcePath & "\" & cStrSourceName)
  End If

'***************************************
  ' Paste data from Source Workbook into Source Array of Arrays.
  ReDim vntSourceAA(UBound(vntWsName))
  For intArr = 0 To UBound(vntWsName)
    With objWbSource.Worksheets(vntWsName(intArr))
      vntSourceAA(intArr) = _
        .Range( _
          .Range(cStrSourceFirst).Cells(1, 1) _
          , .Cells( _
              .Range( _
                .Cells(1, .Range(cStrSourceFirst).Column) _
                , .Cells(Rows.Count, .Range(cStrSourceFirst).Column _
                  + .Range(cStrSourceFirst).Columns.Count - 1)) _
                    .Find(What:="*", _
                    After:=.Range(cStrSourceFirst).Cells(1, 1), _
                    LookIn:=xlFormulas, Lookat:=xlWhole, _
                    SearchOrder:=xlByRows, SearchDirection:=xlPrevious _
                ).Row _
              , .Range(cStrSourceFirst).Column _
                  + .Range(cStrSourceFirst).Columns.Count - 1 _
              ) _
          ).Value2
    End With
  Next
  ' The Source Array of Arrays is a 3-dimensional (jagged) array containing
  ' a 0-based 1-dimensional array containing an 'UBound(vntWsName)' number of
  ' 1-based 2-dimensional arrays.

'***************************************
  ' Count the number of critical data rows to determine size
  ' of each Target Array.
  ReDim vntTargetRows(UBound(vntWsName))
  For intArr = 0 To UBound(vntSourceAA)
    For lngRow = 1 To UBound(vntSourceAA(intArr), 1)
      If vntSourceAA(intArr)(lngRow, 1) = cStrSearch Then
        For lngCount2 = lngRow + 1 To UBound(vntSourceAA(intArr), 1)
          If vntSourceAA(intArr)(lngCount2, 1) <> "" Then
'            Debug.Print vntSourceAA(intArr)(lngCount2, 1)
            lngCount = lngCount + 1
            lngRow = lngRow + 1
           Else
            Exit For
          End If
        Next
      End If
    Next
    vntTargetRows(intArr) = lngCount
    lngCount = 0
  Next

'***************************************
  ' Copy critical data into each Target Array and paste it into
  ' Target Array of Arrays.
  ReDim vntTargetAA(UBound(vntWsName))
  For intArr = 0 To UBound(vntSourceAA)
    ReDim vntTarget(1 To vntTargetRows(intArr), 1 To cIntTargetCols)
    For lngRow = 1 To UBound(vntSourceAA(intArr), 1)
      If vntSourceAA(intArr)(lngRow, 1) = cStrSearch Then
        If cIntTargetCols = 3 Then
          lngCount = lngCount + 1
          vntTarget(lngCount, 1) = vntSourceAA(intArr)(lngRow - 1, 1)
          lngCount = lngCount - 1
        End If
        For lngCount2 = lngRow + 1 To UBound(vntSourceAA(intArr), 1)
          If vntSourceAA(intArr)(lngCount2, 1) <> "" Then
'            Debug.Print vntSourceAA(intArr)(lngCount2, 1)
            lngCount = lngCount + 1
            vntTarget(lngCount, cIntTargetCols - 1) _
                = vntSourceAA(intArr)(lngCount2, 1)
            vntTarget(lngCount, cIntTargetCols) _
                = vntSourceAA(intArr)(lngCount2, 2)
            lngRow = lngRow + 1
           Else
            Exit For
          End If
        Next
      End If
    Next
    vntTargetAA(intArr) = vntTarget
    lngCount = 0
  Next

'***************************************
  ' Clean up
  Erase vntTarget
  Erase vntTargetRows
  Erase vntSourceAA

'***************************************
  ' Paste each Target Array into each of this workbook's worksheet's ranges,
  ' which are starting at the specified cell (cStrTopCell) if no data is below,
  ' or else at the first empty cell found searching from the bottom.
  For intArr = 0 To UBound(vntWsName)
    With ThisWorkbook.Worksheets(vntWsName(intArr))
      If .Cells(Rows.Count, .Range(cStrTopCell).Column + cIntTargetCols - 2) _
          .End(xlUp).Row = 1 Then
        ' No data in column
        strPasteCell = cStrTopCell
       Else
        ' Find first empty cell searching from bottom.
        strPasteCell = _
            .Cells( _
              .Range( _
                .Cells(1, .Range(cStrTopCell).Column) _
                , .Cells(Rows.Count, .Range(cStrTopCell).Column _
                  + cIntTargetCols - 1)) _
                    .Find(What:="*", _
                    After:=.Range(cStrTopCell).Cells(1, 1), _
                    LookIn:=xlFormulas, Lookat:=xlWhole, _
                    SearchOrder:=xlByRows, SearchDirection:=xlPrevious _
                ).Row + 1 _
              , .Range(cStrTopCell).Column _
            ).Address
        ' First empty cell is above Target Top Cell Address.
        If Range(strPasteCell).Row < Range(cStrTopCell).Row Then _
            strPasteCell = cStrTopCell
      End If
      ' Paste into range.
      .Range(strPasteCell).Resize( _
          UBound(vntTargetAA(intArr)) _
          , _
          UBound(vntTargetAA(intArr), 2) _
          ) = vntTargetAA(intArr)
    End With
  Next

'***************************************
  ' Clean up
  Erase vntTargetAA
  Erase vntWsName
  Set objWbSource = Nothing

End Sub
'*******************************************************************************

从变量表复制数据

2 个答案:

数组数组专长。 3维锯齿阵列