比较列的 SUM 以查看是否等于或大于阈值
Compare SUM of columns to see if equal or greater than threshold value
我正在使用 Mac 开发 Excel VBA 宏。因此，任何代码示例都必须使用 Excel for Mac 版本的 Office（使用 Office 365）
所以我想做的是：
将 A 列“名称”及其在 B 列中对应的“等级”值与所有不同的 D、F 和 H 列“等级”（“Sheet1”）中的“等级”值进行比较
我想要获取 A 列“名称”与 C、E 和 G 列“名称”（“Sheet1”）的每个组合
我想将与 A 列关联的“等级”值与 D、F 和 H 列（“Sheet1”）中所有可能的“等级”组合中的“等级”值相加
我想看看这个 SUM 是否大于等于 250
查看“Sheet1”中B列、D列、F列、H列的“成绩”总和是否大于等于250。
如果“Sheet1”“Grade”SUM 大于或等于 250，则：
将“Sheet1”的 A 列“名称”及其对应的 B 列“等级”复制到“Sheet2”的 A 列和 B 列的第一个空行
将“Sheet1”的 C 列“名称”及其相应的 D 列“等级”复制到“Sheet2”的 C 列和 D 列的第一个空行
将“Sheet1”的 E 列“名称”及其对应的 F 列“等级”复制到“Sheet2”的 E 列和 F 列的第一个空行
将“Sheet1”的 G 列“名称”及其对应的 H 列“等级”复制到“Sheet2”的 G 列和 H 列的第一个空行
所以第 Headers 列可能是：
A 列“姓名”
B 栏“等级”
C 列“姓名”
D 栏“等级”
E 列“姓名”
F 栏“等级”
G 列“姓名”
H 列“等级”
示例数据集可能是：
弗雷德 80 岁吉姆 80 岁鲍勃 50 岁鲍勃 40 岁
山姆 60 杰森 10 弗雷德 85 安娜 97
杰森 90 岁安娜 78 岁安娜 65 岁萨姆 99 岁
等等，等等，等等
复制到“Sheet2”的结果可能是（只是一些例子，不能肯定下面的数学是正确的）：
弗雷德 80 吉姆 80 鲍勃 65 安娜 97
弗雷德 80 安娜 78 弗雷德 85 山姆 99
萨姆 60 吉姆 80 弗雷德 85 安娜 97
萨姆 60 安娜 78 鲍勃 50 萨姆 99
杰森 90 吉姆 80 鲍勃 65 萨姆 99
杰森 90 安娜 78 弗雷德 85 萨姆 99
等等，等等，等等
任何低于 250 的内容都不会被复制到“Sheet2”
到目前为止，这是我的代码。
'<---- **** 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 **** ---->
导出数据
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(sName)
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 the data i.e. write the critical rows 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
编辑
Sub ExportCombinedData()
' 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(sName)
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 Source Array ('sData').
Dim sData As Variant: sData = srg.Value
' Define the Destination Array ('dData').
Dim dData As Variant
ReDim dData(1 To srCount ^ (cCount / sStep), 1 To cCount)
' Declare additional variables.
Dim cVal1 As Variant, cVal2 As Variant, cVal3 As Variant, cVal4 As Variant
Dim sr1 As Long, sr2 As Long, sr3 As Long, sr4 As Long
Dim dr As Long ' Current Destination Row
Dim Total As Double ' Current Sum
' Filter the data i.e. write the critical rows to the top
' of the Destination Array.
For sr1 = 1 To srCount
cVal1 = sData(sr1, 2)
If IsNumeric(cVal1) Then
For sr2 = 1 To srCount
cVal2 = sData(sr2, 4)
If IsNumeric(cVal2) Then
For sr3 = 1 To srCount
cVal3 = sData(sr3, 6)
If IsNumeric(cVal3) Then
For sr4 = 1 To srCount
cVal4 = sData(sr4, 8)
If IsNumeric(cVal4) Then
Total = cVal1 + cVal2 + cVal3 + cVal4
If Total >= Minimum Then
dr = dr + 1
dData(dr, 1) = sData(sr1, 1)
dData(dr, 2) = cVal1
dData(dr, 3) = sData(sr2, 3)
dData(dr, 4) = cVal2
dData(dr, 5) = sData(sr3, 5)
dData(dr, 6) = cVal3
dData(dr, 7) = sData(sr4, 7)
dData(dr, 8) = cVal4
End If
End If
Next sr4
End If
Next sr3
End If
Next sr2
End If
Next sr1
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 teh values from the Destination Array
' to the Destination Range ('drg').
Dim drg As Range: Set drg = dfCell.Resize(dr, cCount)
drg.Value = dData
' Inform.
MsgBox dr & " records found.", vbInformation, "Export Combined Data"
End Sub
我正在使用 Mac 开发 Excel VBA 宏。因此，任何代码示例都必须使用 Excel for Mac 版本的 Office（使用 Office 365）
所以我想做的是：
将 A 列“名称”及其在 B 列中对应的“等级”值与所有不同的 D、F 和 H 列“等级”（“Sheet1”）中的“等级”值进行比较
我想要获取 A 列“名称”与 C、E 和 G 列“名称”（“Sheet1”）的每个组合
我想将与 A 列关联的“等级”值与 D、F 和 H 列（“Sheet1”）中所有可能的“等级”组合中的“等级”值相加
我想看看这个 SUM 是否大于等于 250
查看“Sheet1”中B列、D列、F列、H列的“成绩”总和是否大于等于250。
如果“Sheet1”“Grade”SUM 大于或等于 250，则：
将“Sheet1”的 A 列“名称”及其对应的 B 列“等级”复制到“Sheet2”的 A 列和 B 列的第一个空行
将“Sheet1”的 C 列“名称”及其相应的 D 列“等级”复制到“Sheet2”的 C 列和 D 列的第一个空行
将“Sheet1”的 E 列“名称”及其对应的 F 列“等级”复制到“Sheet2”的 E 列和 F 列的第一个空行
将“Sheet1”的 G 列“名称”及其对应的 H 列“等级”复制到“Sheet2”的 G 列和 H 列的第一个空行
所以第 Headers 列可能是：
A 列“姓名”
B 栏“等级”
C 列“姓名”
D 栏“等级”
E 列“姓名”
F 栏“等级”
G 列“姓名”
H 列“等级”
示例数据集可能是：
弗雷德 80 岁吉姆 80 岁鲍勃 50 岁鲍勃 40 岁
山姆 60 杰森 10 弗雷德 85 安娜 97
杰森 90 岁安娜 78 岁安娜 65 岁萨姆 99 岁
等等，等等，等等
复制到“Sheet2”的结果可能是（只是一些例子，不能肯定下面的数学是正确的）：
弗雷德 80 吉姆 80 鲍勃 65 安娜 97
弗雷德 80 安娜 78 弗雷德 85 山姆 99
萨姆 60 吉姆 80 弗雷德 85 安娜 97
萨姆 60 安娜 78 鲍勃 50 萨姆 99
杰森 90 吉姆 80 鲍勃 65 萨姆 99
杰森 90 安娜 78 弗雷德 85 萨姆 99
等等，等等，等等
任何低于 250 的内容都不会被复制到“Sheet2”
到目前为止，这是我的代码。
'<---- **** 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 **** ---->
导出数据
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(sName)
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 the data i.e. write the critical rows 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
编辑
Sub ExportCombinedData()
' 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(sName)
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 Source Array ('sData').
Dim sData As Variant: sData = srg.Value
' Define the Destination Array ('dData').
Dim dData As Variant
ReDim dData(1 To srCount ^ (cCount / sStep), 1 To cCount)
' Declare additional variables.
Dim cVal1 As Variant, cVal2 As Variant, cVal3 As Variant, cVal4 As Variant
Dim sr1 As Long, sr2 As Long, sr3 As Long, sr4 As Long
Dim dr As Long ' Current Destination Row
Dim Total As Double ' Current Sum
' Filter the data i.e. write the critical rows to the top
' of the Destination Array.
For sr1 = 1 To srCount
cVal1 = sData(sr1, 2)
If IsNumeric(cVal1) Then
For sr2 = 1 To srCount
cVal2 = sData(sr2, 4)
If IsNumeric(cVal2) Then
For sr3 = 1 To srCount
cVal3 = sData(sr3, 6)
If IsNumeric(cVal3) Then
For sr4 = 1 To srCount
cVal4 = sData(sr4, 8)
If IsNumeric(cVal4) Then
Total = cVal1 + cVal2 + cVal3 + cVal4
If Total >= Minimum Then
dr = dr + 1
dData(dr, 1) = sData(sr1, 1)
dData(dr, 2) = cVal1
dData(dr, 3) = sData(sr2, 3)
dData(dr, 4) = cVal2
dData(dr, 5) = sData(sr3, 5)
dData(dr, 6) = cVal3
dData(dr, 7) = sData(sr4, 7)
dData(dr, 8) = cVal4
End If
End If
Next sr4
End If
Next sr3
End If
Next sr2
End If
Next sr1
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 teh values from the Destination Array
' to the Destination Range ('drg').
Dim drg As Range: Set drg = dfCell.Resize(dr, cCount)
drg.Value = dData
' Inform.
MsgBox dr & " records found.", vbInformation, "Export Combined Data"
End Sub