主页 / 问题 / 1283667
Accepted
2b4fITin
Asked:2022-05-19 18:16:17 +0000 UTC2022-05-19 18:16:17 +0000 UTC

通过指定参数将字符串选择到数组中

  • 772

同事！将字符串从数组输出到新工作表时，代码（超出范围）崩溃（我什至不确定数组的形成是否一切正常）：

Sub BKFindDeviations()

Dim Deviations() As Variant
Dim rng As Range
Dim Mnth1 As Date
Dim Mnth2 As Date
Dim MnthRowCounter As Long
Dim LoopCounter As Long
Dim r As Range
Dim k As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Mnth1 = "01.01.2020" 'Mnth1 = InputBox("Ââåäèòå ïåðâîå ÷èñëî ìåñÿöà, êîòîðûé áóäåò ñðàâíèâàòüñÿ ñ ïðîøëûìè ìåñÿöàì (ôîðìàò: dd.mm.yyyy")
Mnth2 = "01.02.2020" 'Mnth2 = InputBox("Ââåäèòå ïåðâîå ÷èñëî ìåñÿöà, êîòîðûé áóäåò ÿâëÿòüñÿ áàçîé äëÿ ñðàâíåíèÿ (ôîðìàò: dd.mm.yyyy")

For Each r In Range("a1", Range("a1").End(xlDown))
    If r.Offset(0, 8).Value = Mnth1 Or r.Offset(0, 8).Value = Mnth2 Then
        MnthRowCounter = MnthRowCounter + 1
        ReDim Preserve Deviations(1 To 17, 1 To MnthRowCounter)
        For LoopCounter = 1 To 17 'Range("a1", Range("a1").End(xlToRight))
            Deviations(LoopCounter, MnthRowCounter) = r.Offset(0, LoopCounter - 1).Value
        Next LoopCounter
    End If
Next r

'Deviations = Range("a1", Range("a1").End(xlToRight).End(xlDown))

Worksheets.Add

Range(ActiveCell, ActiveCell.Offset(UBound(Deviations, 1) - 1, UBound(Deviations, 2) - 1)).Value = Deviations

Erase Deviations

Set rng = Range("a1", Range("a1").End(xlDown).End(xlToRight))

'×èñòèì ôîðìàò
With rng
    .ClearFormats
End With

'Óñòàíàâëèâàåì ôîðìàò "Äàòà" â ñòîëáöå Äàò
For k = 1 To Cells(Rows.Count, 9).End(xlUp).Row
    'If Cells(r, 9) Like "##.##.####" Then
        'Cells(r, 9) = DateSerial(Right(Cells(r, 9), 4), Mid(Cells(r, 9), 4, 2), Left(Cells(r, 9), 2))
        Cells(k, 9).NumberFormat = "dd.mm.yyyy;@"
    'End If
Next k

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic End Sub

“出发”前算子所涉及的变量值：

在此处输入图像描述

更新了代码

excel

1 个回答

  1. Best Answer

    我仍然建议现在改用自动过滤器 - 它会变得更短更容易，而且 - 我认为如此 - 更可靠

    Sub BKFindDeviations()
Dim Mnth1 As String, Mnth2 As String
Dim aRng As Range, aDest As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Mnth1 = "01.01.2020" ' Или с помощью InputBox()
Mnth2 = "01.02.2020"
    Set aRng = Range("A1").CurrentRegion
    Worksheets.Add After:=Worksheets(Worksheets.Count)
    Set aDest = Worksheets(Worksheets.Count).Range("A1")
    aRng.AutoFilter
    aRng.AutoFilter Field:=10, Criteria1:="=" & Mnth1, Operator:=xlOr, Criteria2:="=" & Mnth2
    aRng.SpecialCells(xlCellTypeVisible).Copy Destination:=aDest
    Application.CutCopyMode = False
    aRng.AutoFilter
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

    当然，您可以逐行浏览每一行，选择后续复制所需的行。例如，可以这样做：

    Sub BKFindDeviations()
    Dim aRows() As Long
    Dim srcSheet As Worksheet
    Dim src As Range
    Dim aCell As Range
    Dim Mnth1 As Date
    Dim Mnth2 As Date
    Dim MnthRowCounter As Long
    Dim LoopCounter As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Mnth1 = "01.01.2020"
    Mnth2 = "01.02.2020"
    Set srcSheet = ActiveSheet
    Set src = srcSheet.Range("A1").CurrentRegion
    For Each aCell In Intersect(srcSheet.Columns(9), src).Cells
        If aCell.Value = Mnth1 Or aCell.Value = Mnth2 Then
            MnthRowCounter = MnthRowCounter + 1
            ReDim Preserve aRows(1 To MnthRowCounter)
            aRows(MnthRowCounter) = aCell.Row
        End If
    Next aCell
    
    Worksheets.Add
    Set aCell = ActiveSheet.Range("A1")
    src.Rows(1).Copy Destination:=aCell ' Строка заголовков
    Set aCell = aCell.Offset(1, 0)
    For LoopCounter = LBound(aRows) To UBound(aRows)
        src.Rows(aRows(LoopCounter)).Copy Destination:=aCell
        Set aCell = aCell.Offset(1, 0)
    Next LoopCounter
    Erase aRows
    Columns.AutoFit
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
    • 1

相关问题