VBA Excel基于条件的计算值彼此不同

egdjgwm8  于 2023-03-24  发布在  其他
关注(0)|答案(2)|浏览(106)

bounty将在4天后过期。此问题的答案可获得+100声望奖励。Geographos正在查找规范答案：我想有一个解决方案的情况下，其中列H代表三个甚至四个不同的值，而不是只有一个。我想收到正确的数据，为他们每一个，而不是可重复的总值。

我有一个文件夹，里面有很多工作簿，它们的布局几乎是一样的。它们包括了大部分的代码以及相似的值，你可以在H列看到。让我们看看下面的例子：我有代码1682下的值，其中我可能有Uplift代码1128 U，1126 U或其他或简单的空值。我需要计算属于给定代码的所有值（A栏）并提升代码（H列）。这些值将来自给定目录中的所有工作簿。你可以看到这里只是从一个工作簿.我有另外45工作簿与其他值比在下面的屏幕中看到的，我想总结他们.我怎么能做它与下面的代码？

其中在H列中是分配给A列中的代码的不同值。

**我希望为H列中的特定值计算出正确的总和，这些值属于A列中所示的代码。**H列中的这些值可能会在A列中的其他代码中重复，正如您在下面代码1687和4032的情况中看到的那样，但它们必须代表单独的记录。

问题是，简单的条件，如下所示：

Sub SearchFolders_Cables()

 Dim wbAct As Workbook, pathMainWb As String, fldrPath As String
 Dim BOM As String, scrUpdt, WsOut As Worksheet, colFiles As Collection, f As Object
Dim xBol As Boolean, wb As Workbook, ws As Worksheet, arrWs
Dim matchedCells As Collection, Cell, numHits As Long, summRow As Long

Set WsCalc = Workbooks("BoM calculator v4.1G.xlsm")

Set wbAct = ActiveWorkbook
pathMainWb = wbAct.FullName '<<<<

On Error GoTo ErrHandler

fldrPath = UserSelectFolder("Select a folder")
If Len(fldrPath) = 0 Then Exit Sub

'get all files in the selected folder
Set colFiles = GetFileMatches(fldrPath, "*.xls*", False) 'False=no subfolders
If colFiles.Count = 0 Then
    MsgBox "No Excel files found in selected folder"
    Exit Sub
End If
'///////////////////////////CALCULATION EACH CODE FROM ALL FILES IN DIRECTORY/////////////////////////////
lRow = Cells(Rows.Count, 1).End(xlUp).Row
For Each iCell In Range("A2:A" & lRow).Cells
'-----------------------------------CASE 1----------------------------------------
    If iCell.EntireRow.Range("H1").Value = "" Then
        'BOM = InputBox("The current BoM Code is...", "BoM Calculator v1.1", (iCell.Value))
        BOM = iCell.Value
        scrUpdt = Application.ScreenUpdating
        Application.ScreenUpdating = False

        Set WsOut = ThisWorkbook.Worksheets("SUMMARY")
        WsOut.UsedRange.Delete  'Clearing out previous records (very important!!!)

        summRow = 1
        'sheet names to scan
        arrWs = Array("Cable Work Order")
        WsOut.Cells(summRow, 1).Resize(1, 6).Value = Array("Workbook", "Worksheet", _
                        "Cell", "Text in Cell", "Values corresponding", "Uplift Code")
        For Each f In colFiles
            xBol = (f.Path = pathMainWb)  'file already open?
            If xBol Then
                Set wb = wbAct
            Else
                Set wb = Workbooks.Open(FileName:=f.Path, UpdateLinks:=0, _
                                 ReadOnly:=True, AddToMRU:=False)
            End If
    
            For Each ws In wb.Worksheets
            'are we interested in this sheet?
                If Not IsError(Application.Match(ws.Name, arrWs, 0)) Then
                    Set matchedCells = FindAll(ws.UsedRange, BOM) 'get all cells with bom
                    If matchedCells.Count > 0 Then
                        For Each Cell In matchedCells
                            If Cell.EntireRow.Range("H1").Value = "" Then
                                summRow = summRow + 1
                                WsOut.Cells(summRow, 1).Resize(1, 6).Value = _
                                Array(wb.Name, ws.Name, Cell.Address, Cell.Value, _
                                        Cell.EntireRow.Range("F1").Value, Cell.EntireRow.Range("H1").Value)
                
                                numHits = numHits + 1
                            End If
                        Next Cell     'next match
                    End If            'any bom matches
                End If                'matched sheet name
            Next ws
            If Not xBol Then wb.Close False 'need to close this workbook?
        Next f

        With WsOut
            Dim lastrow As Long
            .Columns("A:F").EntireColumn.AutoFit
            lastrow = WsOut.Cells(WsOut.Rows.Count, "E").End(xlUp).Row  'AutoSum all values
            
            .Range("E" & lastrow + 1).Value = WorksheetFunction.Sum(WsOut.Range("E2:E" & lastrow + 1))
        End With
        With ThisWorkbook.Worksheets("Cable Work Order").Range("O1")
            .Font.Color = RGB(240, 240, 240)
            .Value = WsOut.Range("E" & lastrow + 1).Value
        End With

        For i = 2 To Excel.WorksheetFunction.CountA(Range("A:A"))                                        'Autocopy sum value
            If Range("A" & i).Value = BOM Then
               If Range("H" & i).Value = "" Then
                Range("O1").Copy
                With Range("F" & i)
                    .PasteSpecial xlPasteValues
                    .Font.Bold = True
                    .Font.Color = vbBlue
                End With
                End If
            End If
        Next i
'------------------------------------------------------------Case 2----------------------------------------------------------------------------------'
ElseIf iCell.EntireRow.Range("H1").Value = "1126U" Then
        'BOM = InputBox("The current BoM Code is...", "BoM Calculator v1.1", (iCell.Value))
        BOM = iCell.Value
        scrUpdt = Application.ScreenUpdating
        Application.ScreenUpdating = False

        Set WsOut = ThisWorkbook.Worksheets("SUMMARY")
        WsOut.UsedRange.Delete  'Clearing out previous records (very important!!!)

        summRow = 1
        'sheet names to scan
        arrWs = Array("Cable Work Order")
        WsOut.Cells(summRow, 1).Resize(1, 6).Value = Array("Workbook", "Worksheet", _
                        "Cell", "Text in Cell", "Values corresponding", "Uplift Code")
        For Each f In colFiles
            xBol = (f.Path = pathMainWb)  'file already open?
            If xBol Then
                Set wb = wbAct
            Else
                Set wb = Workbooks.Open(FileName:=f.Path, UpdateLinks:=0, _
                                 ReadOnly:=True, AddToMRU:=False)
            End If
    
            For Each ws In wb.Worksheets
            'are we interested in this sheet?
                If Not IsError(Application.Match(ws.Name, arrWs, 0)) Then
                    Set matchedCells = FindAll(ws.UsedRange, BOM) 'get all cells with bom
                    If matchedCells.Count > 0 Then
                        For Each Cell In matchedCells
                            If Cell.EntireRow.Range("H1").Value = "1126U" Then
                                summRow = summRow + 1
                                WsOut.Cells(summRow, 1).Resize(1, 6).Value = _
                                Array(wb.Name, ws.Name, Cell.Address, Cell.Value, _
                                        Cell.EntireRow.Range("F1").Value, Cell.EntireRow.Range("H1").Value)
                
                                numHits = numHits + 1
                            End If
                        Next Cell     'next match
                    End If            'any bom matches
                End If                'matched sheet name
            Next ws
            If Not xBol Then wb.Close False 'need to close this workbook?
        Next f

        With WsOut
            Dim lastrow2 As Long
            .Columns("A:F").EntireColumn.AutoFit
            lastrow2 = WsOut.Cells(WsOut.Rows.Count, "E").End(xlUp).Row  'AutoSum all values
            
            .Range("E" & lastrow2 + 1).Value = WorksheetFunction.Sum(WsOut.Range("E2:E" & lastrow2 + 1))
        End With
        With ThisWorkbook.Worksheets("Cable Work Order").Range("O1")
            .Font.Color = RGB(240, 240, 240)
            .Value = WsOut.Range("E" & lastrow2 + 1).Value
        End With

        For i = 2 To Excel.WorksheetFunction.CountA(Range("A:A"))                                        'Autocopy sum value
            If Range("A" & i).Value = BOM Then
               If Range("H" & i).Value = "1127U" Then
                Range("O1").Copy
                With Range("F" & i)
                    .PasteSpecial xlPasteValues
                    .Font.Bold = True
                    .Font.Color = vbGreen
                End With
                End If
            End If
        Next i
  '------------------------------------------------------------Case 3----------------------------------------------------------------------------------'
ElseIf iCell.EntireRow.Range("H1").Value = "1127U" Then
        'BOM = InputBox("The current BoM Code is...", "BoM Calculator v1.1", (iCell.Value))
        BOM = iCell.Value
        scrUpdt = Application.ScreenUpdating
        Application.ScreenUpdating = False

        Set WsOut = ThisWorkbook.Worksheets("SUMMARY")
        WsOut.UsedRange.Delete  'Clearing out previous records (very important!!!)

        summRow = 1
        'sheet names to scan
        arrWs = Array("Cable Work Order")
        WsOut.Cells(summRow, 1).Resize(1, 6).Value = Array("Workbook", "Worksheet", _
                        "Cell", "Text in Cell", "Values corresponding", "Uplift Code")
        For Each f In colFiles
            xBol = (f.Path = pathMainWb)  'file already open?
            If xBol Then
                Set wb = wbAct
            Else
                Set wb = Workbooks.Open(FileName:=f.Path, UpdateLinks:=0, _
                                 ReadOnly:=True, AddToMRU:=False)
            End If
    
            For Each ws In wb.Worksheets
            'are we interested in this sheet?
                If Not IsError(Application.Match(ws.Name, arrWs, 0)) Then
                    Set matchedCells = FindAll(ws.UsedRange, BOM) 'get all cells with bom
                    If matchedCells.Count > 0 Then
                        For Each Cell In matchedCells
                            If Cell.EntireRow.Range("H1").Value = "1127U" Then
                                summRow = summRow + 1
                                WsOut.Cells(summRow, 1).Resize(1, 6).Value = _
                                Array(wb.Name, ws.Name, Cell.Address, Cell.Value, _
                                        Cell.EntireRow.Range("F1").Value, Cell.EntireRow.Range("H1").Value)
                
                                numHits = numHits + 1
                            End If
                        Next Cell     'next match
                    End If            'any bom matches
                End If                'matched sheet name
            Next ws
            If Not xBol Then wb.Close False 'need to close this workbook?
        Next f

        With WsOut
            Dim lastrow3 As Long
            .Columns("A:F").EntireColumn.AutoFit
            lastrow = WsOut.Cells(WsOut.Rows.Count, "E").End(xlUp).Row  'AutoSum all values
            
            .Range("E" & lastrow3 + 1).Value = WorksheetFunction.Sum(WsOut.Range("E2:E" & lastrow3 + 1))
        End With
        With ThisWorkbook.Worksheets("Cable Work Order").Range("O1")
            .Font.Color = RGB(240, 240, 240)
            .Value = WsOut.Range("E" & lastrow3 + 1).Value
        End With

        For i = 2 To Excel.WorksheetFunction.CountA(Range("A:A"))                                        'Autocopy sum value
            If Range("A" & i).Value = BOM Then
               If Range("H" & i).Value = "1127U" Then
                Range("O1").Copy
                With Range("F" & i)
                    .PasteSpecial xlPasteValues
                    .Font.Bold = True
                    .Font.Color = vbMagenta
                End With
                End If
            End If
        Next i

ElseIf iCell.EntireRow.Range("H1").Value = "1128U" Then  '------------------------------------------------------------Case 4----------------------------------------------------------------------------------'

    'BOM = InputBox("The current Uplift BoM Code is...", "BoM Calculator v1.1", (iCell.Value))
        BOM = iCell.Value
        scrUpdt = Application.ScreenUpdating
        Application.ScreenUpdating = False

        Set WsOut = ThisWorkbook.Worksheets("SUMMARY")
        WsOut.UsedRange.Delete  'Clearing out previous records (very important!!!)

        summRow = 1
        'sheet names to scan
        arrWs = Array("Cable Work Order")
        WsOut.Cells(summRow, 1).Resize(1, 6).Value = Array("Workbook", "Worksheet", _
                        "Cell", "Text in Cell", "Values corresponding", "Uplift Code")
        For Each f In colFiles
            xBol = (f.Path = pathMainWb)  'file already open?
            If xBol Then
                Set wb = wbAct
            Else
                Set wb = Workbooks.Open(FileName:=f.Path, UpdateLinks:=0, _
                                 ReadOnly:=True, AddToMRU:=False)
            End If
    
            For Each ws In wb.Worksheets
            'are we interested in this sheet?
                If Not IsError(Application.Match(ws.Name, arrWs, 0)) Then
                    Set matchedCells = FindAll(ws.UsedRange, BOM) 'get all cells with bom
                    If matchedCells.Count > 0 Then
                        For Each Cell In matchedCells
                            If Cell.EntireRow.Range("H1").Value = "1128U" Then
                                summRow = summRow + 1
                                WsOut.Cells(summRow, 1).Resize(1, 6).Value = _
                                Array(wb.Name, ws.Name, Cell.Address, Cell.Value, _
                                        Cell.EntireRow.Range("F1").Value, Cell.EntireRow.Range("H1").Value)
                
                                numHits = numHits + 1
                            End If
                        Next Cell     'next match
                    End If            'any bom matches
                End If                'matched sheet name
            Next ws
            If Not xBol Then wb.Close False 'need to close this workbook?
        Next f

        With WsOut
            Dim lastrow4 As Long
            .Columns("A:F").EntireColumn.AutoFit
            lastrow2 = WsOut.Cells(WsOut.Rows.Count, "E").End(xlUp).Row  'AutoSum all values
            
            .Range("E" & lastrow4 + 1).Value = WorksheetFunction.Sum(WsOut.Range("E2:E" & lastrow4 + 1))
        End With
        With ThisWorkbook.Worksheets("Cable Work Order").Range("O1")
            .Font.Color = RGB(240, 240, 240)
            .Value = WsOut.Range("E" & lastrow4 + 1).Value
        End With

        For i = 2 To Excel.WorksheetFunction.CountA(Range("A:A"))                                        'Autocopy sum value
            If Range("A" & i).Value = BOM Then
               If Range("H" & i).Value = "1128U" Then
                Range("O1").Copy
                With Range("F" & i)
                    .PasteSpecial xlPasteValues
                    .Font.Bold = True
                    .Font.Color = vbRed
                End With
                End If
            End If
        Next I

  End If
  Next iCell

 MsgBox "Process completed"

 ExitHandler:
 Application.ScreenUpdating = scrUpdt
 Exit Sub

 ErrHandler:
 MsgBox Err.Description, vbExclamation
 Resume ExitHandler


 End Sub

我得到了错误的值，正如你在下面看到的：

在标准情况下，当考虑H列是否存在值时，我有两个单独的记录，这很好。当代码扩展时，情况就复杂了。然后我可以得到第三个记录的值，但第二个记录仍然是相同的，而该值应该减去记录3的值。
是否有一种方法可以为任何值设置条件，这些条件彼此不同？
我在考虑多个或条件Compress multiple OR-conditions in VBA code
但是它们在我的情况下不起作用。例如，Case - switch选项会更好吗？或者嵌套if条件？我需要确保，代码将H列中的每个值彼此不同地对待。所以这种方法可能会有所帮助：Quicker way to get all unique values of a column in VBA?

excel

2条答案

按热度按时间
a9wyjsp7

a9wyjsp71#

我把它排序了，但方法很平凡，因此这个问题仍然有效。
我使用了multiple or语句，它看起来像这样：

'.................first case the same as above............

ElseIf iCell.EntireRow.Range("H1").Value = "1126U" _
Or iCell.EntireRow.Range("H1").Value = "1672U" _
Or iCell.EntireRow.Range("H1").Value = "1688U" _
Or iCell.EntireRow.Range("H1").Value = "1887U" _
Or iCell.EntireRow.Range("H1").Value = "1985U" _
Or iCell.EntireRow.Range("H1").Value = "4100U" _
Or iCell.EntireRow.Range("H1").Value = "MDU501U" _
Then

   '-------------code as above '-------------------

  If matchedCells.Count > 0 Then
                        For Each Cell In matchedCells
                            If Cell.EntireRow.Range("H1").Value = "1126U" _
                            Or Cell.EntireRow.Range("H1").Value = "1672U" _
                            Or Cell.EntireRow.Range("H1").Value = "1688U" _
                            Or Cell.EntireRow.Range("H1").Value = "1887U" _
                            Or Cell.EntireRow.Range("H1").Value = "1985U" _
                            Or Cell.EntireRow.Range("H1").Value = "4100U" _
                            Or Cell.EntireRow.Range("H1").Value = "MDU501U" _
                            Then

'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

For i = 2 To Excel.WorksheetFunction.CountA(Range("A:A"))                                        
  'Autocopy sum value
            If Range("A" & i).Value = BOM Then
               If Range("H" & i).Value = "1126U" _
               Or Range("H" & i).Value = "1672U" _
               Or Range("H" & i).Value = "1688U" _
               Or Range("H" & i).Value = "1887U" _
               Or Range("H" & i).Value = "1985U" _
               Or Range("H" & i).Value = "4100U" _
               Or Range("H" & i).Value = "MDU501U" _
               Then
赞(0）分享  回复(0）举报  2023-03-24
lsmepo6l

lsmepo6l2#

根据我对您的代码的理解，它对列A和列H的组合进行了列F的求和。

Option Explicit

Sub SearchFolders_Cables()

    Dim FOLDER As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a folder"
        .InitialFileName = ""
        .Show
        .AllowMultiSelect = False
        If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
            MsgBox "You did not select a folder"
            Exit Sub
        End If
        FOLDER = .SelectedItems(1) & "\" 'Assign selected folder to Folder
    End With

    Dim wb As Workbook, ws As Worksheet, lastrow As Long, r As Long
    Dim dict, k, n As Long, t0 As Single: t0 = Timer
    
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Cable Work Order") ' ActiveSheet
    
    ' build dictionary for totals
    Set dict = CreateObject("Scripting.Dictionary")
    With ws
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For r = 2 To lastrow
            ' key - Uplift Code & BOM
            k = Trim(.Cells(r, "H")) & vbTab & Trim(.Cells(r, "A"))
            If Not dict.exists(k) And Len(k) > 1 Then
                dict.Add k, 0
            End If
        Next
    End With
    'For Each k In dict.keys: Debug.Print k, dict(k): Next
    
    ' search workbooks in folder
    Dim arrWs, wbF As Workbook, wsF As Worksheet
    Dim f As String
   
    arrWs = Array("Cable Work Order")
    
    f = Dir(FOLDER & "*.xls*")
    Application.ScreenUpdating = False
    Do While Len(f) > 0
       n = n + 1
       Set wbF = Workbooks.Open(FOLDER & f, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
       For Each wsF In wbF.Sheets
           If IsError(Application.Match(wsF.Name, arrWs, 0)) Then
                'Debug.Print "Skipped", wbF.Name, wsF.Name
           Else
                ' process sheet
                Call ProcessSheet(wsF, dict)
            End If
        Next
        ' close workbook
        wbF.Close
        f = Dir
    Loop
    
    ' update results
    With ws
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For r = 2 To lastrow
            k = Trim(.Cells(r, "H")) & vbTab & Trim(.Cells(r, "A"))
            If dict.exists(k) Then
                .Cells(r, "F") = dict(k)
            End If
        Next
    End With
    Application.ScreenUpdating = True
    
    MsgBox n & " files scanned in " & FOLDER, vbInformation, Format(Timer - t0, "0.0 secs")
End Sub

Sub ProcessSheet(ws, dict)
    Dim lastrow As Long, r As Long, k As String
    With ws
        lastrow = ws.UsedRange.Row + ws.UsedRange.Rows.Count - 1
        For r = 1 To lastrow
            k = Trim(.Cells(r, "H")) & vbTab & Trim(.Cells(r, "A"))
            ' sum quantity
            If dict.exists(k) Then
                dict(k) = dict(k) + .Cells(r, "F")
            End If
        Next
    End With
End Sub
赞(0）分享  回复(0）举报  2023-03-24
我来回答

相关问题

    查看更多

    热门标签

    更多
    JavaquerypythonNode开发语言requestUtil数据库Table后端算法LoggerMessageElementParser

    最新问答

    更多
    • 蜀ICP备2022004421号-2 NULL123 https://www.null123.com © All rights reserved
    • 本站内容来源互联网,如果侵犯您的权益请联系我们删除, 联系方式：448109455@qq.com