比较列的 SUM 以查看是否等于或大于阈值

Question

I am working on an Excel VBA macro using a Mac. So any code examples would have to work with the Excel for Mac version of Office (Using Office 365)

So what I want to do is:

Compare the Column A "Name" with its corresponding "Grade" values in Column B to the "Grade" values in all the different Columns D, F, and H "Grade" ("Sheet1")

I want to get every combo of the Column A "Name" with the Column C, E, and G "Name" ("Sheet1")

I want to SUM the "Grade" value that is associated to Column A to the "Grade" values in all the possible combo of "Grade" in Columns D, F, and H ("Sheet1")

I want to see if this SUM is greater to or equal to 250

See if the value of the SUM of the "Grade" in Column B, Column D, Column F, and Column H in "Sheet1" is greater than or equal to 250.

If the "Sheet1" "Grade" SUM is greater to or equal to 250 Then:

Copy the Column A "Name" with its corresponding Column B "Grade" of "Sheet1" to the first empty row in Column A and B of "Sheet2"

Copy the Column C "Name" with its corresponding Column D "Grade of "Sheet1" to the first empty row in Column C and D of "Sheet2"

Copy the Column E "Name" with its corresponding Column F "Grade" of "Sheet1" to the first empty row in Column E and F of "Sheet2"

Copy the Column G "Name" with its corresponding Column H "Grade" of "Sheet1" to the first empty row in Column G and H of "Sheet2"

So the Column Headers might be:

Column A "Name"

Column B "Grade"

Column C "Name"

Column D "Grade"

Column E "Name"

Column F "Grade"

Column G "Name"

Column H "Grade"

A sample data set might be:

Fred 80 Jim 80 Bob 50 Bob 40

Sam 60 Jason 10 Fred 85 Anna 97

Jason 90 Anna 78 Anna 65 Sam 99

etc, etc, etc

Results copied to "Sheet2" might be (just some examples, not positive that the math below is correct):

Fred 80 Jim 80 Bob 65 Anna 97

Fred 80 Anna 78 Fred 85 Sam 99

Sam 60 Jim 80 Fred 85 Anna 97

Sam 60 Anna 78 Bob 50 Sam 99

Jason 90 Jim 80 Bob 65 Sam 99

Jason 90 Anna 78 Fred 85 Sam 99

etc, etc, etc

Anything below 250 just wouldn't get copied over to "Sheet2"

Here is my code so far.

'<---- **** START OF CODE **** ---->

Sub Test()
  '<---- Declare the variables needed
  Dim wb As Workbook, ws1, ws2 As Worksheet, ws1LastRow, ws2LastRow, i As Long

'<---- Set the value of the variables needed for the loop
Set wb = ThisWorkbook
Set ws1 = wb.Worksheets("Sheet1")
Set ws2 = wb.Worksheets("Sheet1")
ws1LastRow = ws1.Cells(Rows.Count, "A").EnColumn D(xlUp).row
ws2LastRow= ws2.Cells(Rows.Count, "A").EnColumn D(xlUp).row

'<---- Loop thru the values of Columns B, D, F, and H of Sheet1
For i = 1 To ws1LastRow
  If WorksheetFunction.SUM(ws1.Cells(i, "B").Value, ws1.Cells(i, "D").Value, ws1.Cells(i, "F").Value, ws1.Cells(i, "H").Value) > 250 Then
'<---- If value of the SUM above is > or = to 250, then copy the Column A:H values of Sheet1 to Sheet2
'<---- Ignore if less than 250
'<----- Make sure to compare every (i, 'A') value with every combo of (i, 'C') value, (i, 'E') value,  and (i, 'G') value
    ws1.Cells(i, "A").Copy Destination:=ws2.Cells(ws2LastRow, "A")
    ws1.Cells(i, "B").Copy Destination:=ws2.Cells(ws2LastRow, "B")
    ws1.Cells(i, "C").Copy Destination:=ws2.Cells(ws2LastRow, "C")
    ws1.Cells(i, "D").Copy Destination:=ws2.Cells(ws2LastRow, "D")
    ws1.Cells(i, "E").Copy Destination:=ws2.Cells(ws2LastRow, "E")
    ws1.Cells(i, "F").Copy Destination:=ws2.Cells(ws2LastRow, "F")
    ws1.Cells(i, "G").Copy Destination:=ws2.Cells(ws2LastRow, "G")
    ws1.Cells(i, "H").Copy Destination:=ws2.Cells(ws2LastRow, "H"): ws2LastRow = ws2LastRow + 1
  End If
Next i
End Sub

'<---- **** END OF CODE **** ---->

Answer 1

Export Data

Option Explicit

Sub ExportData()
' Needs 'RefColumns'.
    
    ' Source
    Const sName As String = "Sheet1"
    Const sCols As String = "A:H"
    Const sfRow As Long = 2
    Const sfsCol As Long = 2
    Const sStep As Long = 2
    ' Destination
    Const dName As String = "Sheet2"
    Const dFirst As String = "A2"
    ' Other
    Const Minimum As Double = 250
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Create a reference to the Source Range ('srg').
    Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
    Dim sfrrg As Range: Set sfrrg = sws.Rows(sfRow).Columns(sCols)
    Dim srg As Range: Set srg = RefColumns(sfrrg)
    If srg Is Nothing Then Exit Sub ' no data
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim cCount As Long: cCount = srg.Columns.Count ' same for src and dest
    
    ' Write the values from the Source Range to the Data Array ('Data').
    Dim Data As Variant: Data = srg.Value
    
    ' Declare additional variables.
    Dim cValue As Variant ' Current Value
    Dim sr As Long ' Current Source Row
    Dim c As Long ' Current Column (same for src and dest)
    Dim dr As Long ' Current Destination Row
    Dim Total As Double ' Current Sum
    
    ' 'Filter' data i.e. write the desired values to the top
    ' of the Data Array.
    For sr = 1 To srCount
        Total = 0
        For c = sfsCol To cCount Step sStep
            cValue = Data(sr, c)
            If IsNumeric(cValue) Then
                Total = Total + cValue
            End If
        Next c
        If Total >= Minimum Then
            dr = dr + 1
            For c = 1 To cCount
                Data(dr, c) = Data(sr, c)
            Next c
        End If
    Next sr
    
    If dr = 0 Then Exit Sub ' no 'Total >= Mininum' found
    
    ' Create a reference to the Destination First Cell ('dfCell').
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
    
    ' Clear the Destination Clear Range ('dclrg') e.g. 'A2:XFD1048576'.
    With dfCell
        Dim dclrg As Range: Set dclrg = .Resize(dws.Rows.Count - .Row, _
            dws.Columns.Count - .Column).Offset(.Row - 1, .Column - 1)
        dclrg.Clear
    End With
    
    ' Write from the Data Array to the Destination Range ('drg').
    Dim drg As Range: Set drg = dfCell.Resize(dr, cCount)
    drg.Value = Data

    ' Inform.
    MsgBox dr & " records found.", vbInformation, "Export Data"

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the range from the first row of a range
'               ('FirstRowRange') through the row range containing
'               the bottom-most non-empty cell in the row's columns.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumns( _
    ByVal FirstRowRange As Range) _
As Range
    If FirstRowRange Is Nothing Then Exit Function
    
    With FirstRowRange.Rows(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , xlByRows, xlPrevious)
        If lCell Is Nothing Then Exit Function ' empty range
        Set RefColumns = .Resize(lCell.Row - .Row + 1)
    End With

End Function