excel - 修剪功能无法正常工作，我做错了什么？

Question

背景:在工作中，客户对他们使用了很长时间的 Excel 宏有疑问。简而言之，该宏读取 .txt 文件，修剪掉 A 列中不包含值“22300”的行(从“Rekening”一词下方开始)添加与剩余行关联的数字的总值并生成一个结果的 Excel 文件。

当前结果:更改提供的 .txt 文件模板(微小更改)后，宏已停止工作。当用户启动宏(通过单击图像/形状)时，宏开始运行但给出 1004 错误(窗口错误)。当用户单击确定时，宏会继续生成 Excel 文件，但没有应用修剪功能并添加总值。

我已经仔细检查了文件中“Rekening”和“22300”的拼写。除此之外，我还尝试再次使用偏移值，但我不确定我在做什么，因为我对此很陌生。

Option Explicit
Sub OpenBestand()
    Application.DisplayAlerts = False
    Dim sBronMap As String
    Dim sResultmap As String
    Dim sDonemap As String
    Dim sBronbest As String
    Dim wbBron As Workbook

    On Error GoTo Errorhandler

    sBronMap = Blad1.Range("Bronmap").Value
    If Right(sBronMap, 1) <> "\" Then sBronMap = sBronMap & "\"

    sBronbest = Dir(sBronMap & "*.prt", vbNormal)
    If sBronbest = "" Then
        sBronbest = Dir(sBronMap & "*.txt", vbNormal)
    End If
    Application.DisplayAlerts = False
    If sBronbest <> "" Then
        With Application
            .ScreenUpdating = False
            .StatusBar = "Even geduld bezig met verwerken bestand " & sBronbest
        End With

        Workbooks.OpenText Filename:=sBronMap & sBronbest, _
            Origin:=xlWindows, _
            StartRow:=9, _
            DataType:=xlFixedWidth, _
            FieldInfo:=Array(Array(0, 1), _
                            Array(9, 1), _
                            Array(18, 1), _
                            Array(33, 1), _
                            Array(53, 1), _
                            Array(69, 2), _
                            Array(78, 1), _
                            Array(88, 1), _
                            Array(95, 1), _
                            Array(109, 1), _
                            Array(123, 1), _
                            Array(129, 1)), _
                            TrailingMinusNumbers:=True

        Set wbBron = ActiveWorkbook
        Bewerkbestand wbBron

    Else
        MsgBox "geen bestand gevonden", vbInformation, "Mededeling"
        Exit Sub
    End If

    sResultmap = Blad1.Range("Resultmap").Value
    If Right(sResultmap, 1) <> "\" Then sResultmap = sResultmap & "\"
    wbBron.SaveAs sResultmap & Left(wbBron.Name, InStr(1, wbBron.Name, ".") - 1), xlWorkbookNormal

    sDonemap = Blad1.Range("Donemap").Value
    If Right(sDonemap, 1) <> "\" Then sDonemap = sDonemap & "\"

    FileCopy sBronMap & sBronbest, sDonemap & sBronbest
    Kill sBronMap & sBronbest

    wbBron.Activate
    With ActiveWindow
        .ScrollColumn = 1
        .ScrollRow = 1
    End With

    With Application
        .ScreenUpdating = True
        .StatusBar = False
    End With

    ThisWorkbook.Close SaveChanges:=False
Exit Sub
Errorhandler:
    MsgBox Err.Number & " " & Err.Description, vbCritical, "Fout tijdens verwerking!"
    With Application
        .ScreenUpdating = True
        .StatusBar = False
    End With
End Sub


Sub Bewerkbestand(ByVal wbBron As Workbook)
    On Error GoTo Errorhandler

    Dim contrCel As Range, StartCel As Range
    Dim TotBedr As Double

    TotBedr = 0
    Set contrCel = wbBron.Worksheets(1).Range("A1")
    Do While UCase(Trim(contrCel.Value)) <> "Rekening"
        Set contrCel = contrCel.Offset(1, 0)
    Loop
    Set StartCel = contrCel

    Set contrCel = contrCel.Offset(2, 0)
    Do While contrCel.Value & contrCel.Offset(1, 0).Value & contrCel.Offset(2, 0).Value <> ""
        If contrCel.Value <> "22300" Then
            Set contrCel = contrCel.Offset(-1, 0)
            contrCel.Offset(1, 0).EntireRow.Delete
        Else
        End If
        Set contrCel = contrCel.Offset(1, 0)
    Loop

    'Bedragen optellen
    Set contrCel = StartCel.Offset(2, 0)
    Do While contrCel.Value <> ""
        TotBedr = TotBedr + CDbl(contrCel.Offset(0, 9).Value)
        Set contrCel = contrCel.Offset(1, 0)
    Loop

    With StartCel
        .Offset(-2, 8).Value = "Totaalbedrag"
        .Offset(-2, 8).Font.Bold = True
        .Offset(-2, 8).HorizontalAlignment = xlRight
        .Offset(-2, 9).Value = TotBedr
        .Offset(-2, 9).EntireColumn.ColumnWidth = 16
        .Offset(-2, 9).Font.Bold = True
    End With

Exit Sub

Errorhandler:
MsgBox Err.Number & " " & Err.Description, vbCritical, "Fout tijdens verwerking!"

End Sub

我已经包含了输入和所需/先前生成的输出的屏幕截图。

输入截图



所需/先前生成的输出



这是一个txt文件的内容(显然已编辑)以供引用:

    A(s0V&k0V&l0o8V(s12.66A                                     G X X X X E E E K   V E E E E E K I I I I R E E E E E G

=================================================================================================================================
 Integr.bestand:  MEMO      Periode:     Dagb:  Soci Zac Stap                                     Bladnr:    1

=================================================================================================================================
Rekening     Kostenpl. Kostendr. Rekeningnaam        Omschrijving    Boekstuk Datum     Periode         Debet        Credit
=================================================================================================================================
 RUNPARAMETERS
 GEBRUIKER   : Gxx
 Gemo    : 001
 Financiele integratie Kup
 Periode             : 201907
 Verslagnummer van   : 180000
 Verslagnummer t/m   : 180022
 Periode             : 201907
 Regeling(en)        : 0 Regeling 1
                       1 Regeling 2
                       2 Regeling 3
                       3 Regeling 4
                       4 Regeling 5
                       5 Regeling 6
                       6 Regeling 7
                       7 Regeling 8
                       8 Regeling 9
                       9 Regeling 10
                       10 Regeling 11
                       11 Regeling 12
                       12 Regeling 13
                       13 Regeling 14
 Boekingsdatum van   : --
 Boekingsdatum t/m   : --
 EINDE RUNPARAMETERS
                                     G X X X X E E E K   V E E E E E K I I I I R E E E E E G

=================================================================================================================================
 Integr.bestand:  MEMO      Periode:     Dagb:  Soci Zac Stap                                     Bladnr:    2

=================================================================================================================================
Rekening     Kostenpl. Kostendr. Rekeningnaam        Omschrijving    Boekstuk Datum     Periode         Debet        Credit
=================================================================================================================================
 60XXXXXX    4XXXX               NXXXXXXXXXXX        PXXX            0XXXXXXX 30-07-2019 201906       1XX,XX
 60XXXXXX    4XXXX               IXXXXXXXX           PXXX            0XXXXXXX 30-07-2019 201906                      7X,XX
 60XXXXXX    4XXXX               OXXXXXXXXXXXXXXXX   PXXX            0XXXXXXX 30-07-2019 201906                    8XXX,XX
    22300                        BXXXXXXX            PXXX            0XXXXXXX 30-07-2019 201906                    3XXX,XX
 60XXXXXX    4XXXX               EXXXXXXXXXX         PXXX            0XXXXXXX 30-07-2019 201906      6XXX,XX
    22304                        AXXXXXXXXXXXXXXXXXX PXXX            0XXXXXXX 30-07-2019 201906                    6XXX,XX
 60XXXXXX    4XXXX               VXXXXXXXXXXX        PXXX            0XXXXXXX 30-07-2019 201906       5XX,13
 60XXXXXX    4XXXX               RXXXXXXXXXXXXX      PXXX            0XXXXXXX 30-07-2019 201906                     5XX,XX
 60XXXXXX    4XXXX               LXXXXXXXXXXXXXXXXXX PXXX            0XXXXXXX 30-07-2019 201906     1XXXX,XX

                                                                                                ------------- -------------
Totalen :                                                                                           4XXX,XX      4XXX,XX
                                                                                                ============= =============

Answer 1

主要问题在这一行

Do While UCase(Trim(contrCel.Value)) <> "Rekening"

您正在寻找 UCase表示单元格值中的所有字符都通过 UCase 转换为大写所以当谈到 Rekening你比较 "REKENING" <> "Rekening"所以它不匹配。您需要将其更改为

Do While UCase(Trim(contrCel.Value)) <> "REKENING"

但我建议使用 Range.Find method应该找到 "Rekening"比循环快。您可以使其不区分大小写 MatchCase:=False让它查看单元格的一部分 LookAt:=xlPart所以你不需要 Trim .

Set StartCel = wbBron.Worksheets(1).Columns("A").Find(What:="Rekening", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)

查看 Bewerkbestand 的完整改进代码程序如下:

Sub Bewerkbestand(ByVal wbBron As Workbook)
    On Error GoTo Errorhandler

    Dim StartCel As Range
    Set StartCel = wbBron.Worksheets(1).Columns("A").Find(What:="Rekening", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)

    If StartCel Is Nothing Then
        MsgBox "'Rekening' could not be found.", vbCritical
        Exit Sub
    End If

    Dim contrCel As Range
    Set contrCel = StartCel.Offset(2, 0)
    Do While contrCel.Value & contrCel.Offset(1, 0).Value & contrCel.Offset(2, 0).Value <> ""
        If contrCel.Value <> "22300" Then
            Set contrCel = contrCel.Offset(-1, 0)
            contrCel.Offset(1, 0).EntireRow.Delete
        Else
        End If
        Set contrCel = contrCel.Offset(1, 0)
    Loop

    'Bedragen optellen
    Set contrCel = StartCel.Offset(2, 0)

    Dim TotBedr As Double
    Do While contrCel.Value <> ""
        TotBedr = TotBedr + CDbl(contrCel.Offset(0, 9).Value)
        Set contrCel = contrCel.Offset(1, 0)
    Loop

    With StartCel
        .Offset(-2, 8).Value = "Totaalbedrag"
        .Offset(-2, 8).Font.Bold = True
        .Offset(-2, 8).HorizontalAlignment = xlRight
        .Offset(-2, 9).Value = TotBedr
        .Offset(-2, 9).EntireColumn.ColumnWidth = 16
        .Offset(-2, 9).Font.Bold = True
    End With


    Exit Sub
Errorhandler:
    MsgBox Err.Number & " " & Err.Description, vbCritical, "Fout tijdens verwerking!"
End Sub