Question

我遇到了自制vba代码的问题。 makro应解决以下问题：我使用“cockpitfile”它应该将两个不同Excel文件中的两个工作表的元素加载到两个数组中。这些数组的元素应相互减去。我想从这两个元素中获得差异。例如：ArrayElm1（1,1） - ArrayElm2（1,1）= ArrayElm3（1,1），ArrayElm1（1,2） - ArrayElm2（1,2）= ArrayElm3（1,2）等

第一眼看上去代码似乎有效，但是当我用计算器检查结果时，元素的差异是错误的。也许2存在问题，因为我的UBound只有数组A？

希望你能帮助我！

Ubound

Answer 1

你几乎没错，但问题是你没有重置ArrayC

此代码在ThisWorkbook中创建新的工作表以进行减法，并根据您的previous question检查错误，并仅在两个值均为数字时执行减法

Option Explicit

Public Sub Differenz2()
    Const USED_RNG = "F5:Y75"   'Main range
    Dim i As Long, j As Long, k As Long, file1 As String, file2 As String, ws1Count As Long
    Dim wb1 As Workbook, wb2 As Workbook, arr1 As Variant, arr2 As Variant, arr3 As Variant

    'ChDrive "O:\":  ChDir "O:..."
    file1 = Application.GetOpenFilename:    If file1 = "False" Then Exit Sub
    file2 = Application.GetOpenFilename:    If file2 = "False" Then Exit Sub
    Application.ScreenUpdating = False
    Set wb1 = Workbooks.Open(Filename:=file1, ReadOnly:=True)
    Set wb2 = Workbooks.Open(Filename:=file2, ReadOnly:=True)
    ws1Count = wb1.Worksheets.Count
    If ws1Count = wb2.Worksheets.Count Then
        MakeNewWS ws1Count    'Remove this line if ThisWorkbook is properly setup
        For k = 1 To ws1Count
            arr1 = wb1.Worksheets(k).Range(USED_RNG).Value
            arr2 = wb2.Worksheets(k).Range(USED_RNG).Value
            ReDim arr3(1 To 71, 1 To 20)    'reset array, based on USED_RNG ("F5:Y75")
            For i = LBound(arr1, 1) To UBound(arr1, 1)
                For j = LBound(arr1, 2) To UBound(arr1, 2)
                    If Not IsError(arr1(i, j)) And Not IsError(arr2(i, j)) Then
                        If IsNumeric(arr1(i, j)) And IsNumeric(arr2(i, j)) Then
                            arr3(i, j) = arr1(i, j) - arr2(i, j)
                        End If
                    End If
                Next
            Next
            ThisWorkbook.Worksheets(k + 1).Range(USED_RNG) = arr3
        Next
    End If
    wb1.Close False:    wb2.Close False:    ThisWorkbook.Worksheets(2).Activate
    Application.ScreenUpdating = True
End Sub

Private Sub MakeNewWS(ByVal wsCount As Long)
    Dim i As Long, ws As Worksheet

    With ThisWorkbook.Worksheets
        Application.DisplayAlerts = False
        For Each ws In ThisWorkbook.Worksheets
            If Left(ws.Name, 12) = "Subtraction " Then
                If .Count = 1 Then .Add
                ws.Delete
            End If
        Next
        Application.DisplayAlerts = True
        For i = 2 To wsCount + 1
            .Add After:=ThisWorkbook.Worksheets(.Count)
            ThisWorkbook.Worksheets(.Count).Name = "Subtraction " & i - 1
        Next
    End With
End Sub

如果ThisWorkbook包含适当数量的工作表

，则可以忽略MakeNewWS()子

此外，使用数组确实可以显着提高性能

减去两个多维数组VBA

1 个答案: