Question

我是VBA的新手，并且遇到了特定问题。我有一张乱七八糟的桌子，需要从中提取单元格序列（图像中以红色突出显示）。它以随机模式出现在表中，但是始终以相同的顺序和格式显示（日期>数字>数字>数字>字符）。我需要提取所有这些序列并将它们整理在表的末尾，如image2所示。将不胜感激，因为我是vba的新手，因此无法获得代码，因此将为您提供帮助。我认为的逻辑可以帮助解决此问题 1）遍历行 2）匹配格式 3）如果匹配则提取值除了检查连续格式，还可以查看其他任何逻辑。这就是我能想到的

VBA的新功能。如前所述到达代码逻辑

如图所示

Answer 1

您的逻辑是正确的，您必须在符合条件的行和列之间进行迭代，查找值作为日期，并且同一行的下一列必须包含数字值，希望此代码示例对您有所帮助

Sub example() Dim clm, rw, clm2, rw2, i As Long rw2=1 '1. loop trough used range rows and columns For clm = 1 To ActiveSheet.UsedRange.Columns.Count For rw = 1 To ActiveSheet.UsedRange.Rows.Count 'validate if current cell value is date If IsDate(Cells(rw, clm)) = True Then 'validate if current cell value is numeric If IsNumeric(Cells(rw, clm + 1)) = True Then 'add another sheet to store the values ' five subsequent columns same cell cells clm2 =1 For i = 0 To 5 ActiveWorkbook.Sheets("AnotherSheet").Cells(rw2, clm2).Value = ActiveSheet.Cells(rw, clm + i) Next i rw2=rw2+1 End If End If Next rw Next clm End Sub

Answer 2

我的代码假定Date, Number, Number, Number, Text单元格始终彼此位于同一行上（尽管它们可能存在于该行中的任何位置）。

此代码期望您已经准备好空白的输出页。我添加了更多注释来解释循环中发生的事情。

根据需要更改OUTPUT_SHEET_NAME的值。

Option Explicit

Sub CollateValues()

    Const OUTPUT_SHEET_NAME As String = "Sheet2" ' Change this as needed.

    Dim outputSheet As Worksheet
    Set outputSheet = ThisWorkbook.Worksheets(OUTPUT_SHEET_NAME)

    ' Write hardcoded list of headers to output sheet
    outputSheet.Range("A1").Resize(1, 5) = Array("Date", "Outstanding", "Overdue", "NPI", "Status")

    Dim outputRowIndex As Long
    outputRowIndex = 1 ' Skip headers

    Dim inputSheet As Worksheet ' Used to loop over worksheets

    For Each inputSheet In ThisWorkbook.Worksheets
        If inputSheet.Name <> OUTPUT_SHEET_NAME Then
            With inputSheet

                Dim numericCellsFound As Range
                On Error Resume Next
                Set numericCellsFound = .Cells.SpecialCells(xlCellTypeConstants, xlNumbers) ' Suppress error if no cells were found
                On Error GoTo 0

                If Not (numericCellsFound Is Nothing) Then ' Check if any cells were found on previous lines
                    Dim cell As Range
                    Dim numericCell As Range

                    ' Dates are basically numbers, so loop through all numeric cells.
                    For Each numericCell In numericCellsFound
                        If IsDate(numericCell) Then ' Check if the cell we're currently looping through is a date
                            If Application.Count(numericCell.Offset(0, 1).Resize(1, 3)) = 3 Then ' Check if the next three cells to the right of the date are all numbers. We use the worksheet function COUNT, which you may be familiar with.
                                If Application.IsText(numericCell.Offset(0, 4)) Then ' Check if the fourth cell to the right of the date is text/characters. The worksheet function ISTEXT is used.
                                    outputRowIndex = outputRowIndex + 1 ' We want to write to the next line, so increment this variable by 1.
                                    numericCell.Resize(1, 5).Copy outputSheet.Cells(outputRowIndex, "A") ' Copy-paste the 5 cells (Date, Number, Number, Number, Text), which have passed all the checks on the previous lines, to the next row on the output worksheet.
                                End If
                            End If
                        End If
                    Next numericCell

                    Set numericCellsFound = Nothing ' Reset this, otherwise the current iteration's results can be affected by a previous iteration.
                End If
            End With
        End If
    Next inputSheet
End Sub

连续识别具有相似格式的一系列单元格并将其提取出来

2 个答案: