我正在使用Mac操作Excel VBA宏。因此，任何代码示例都必须使用Excel for Mac版本的Office(使用Office 365(
所以我想做的是：
比较列A"；名称"；其对应的"；等级"；列B中的值到"；等级"；所有不同列D、F和H"中的值；等级"；("Sheet1"(
我想得到列A"的每个组合；名称"；其中列C、E和G"；名称"；("Sheet1"(
我想求和"；等级"；与列A相关联的值到"；等级"；在所有可能的"0"组合中的值；等级"；在D、F和H列("Sheet1"(中
我想看看这个总和是否大于或等于250
看看"；等级"；在"A"中的B列、D列、F列和H列中；Sheet1"；大于或等于250。
如果"；Sheet1"等级"；SUM大于或等于250然后：
复制列A"；名称"；其对应的列B"；等级"；的"；Sheet1"；到"0"的列A和B中的第一个空行；片材2"；
复制列C"；名称"；其对应的列D"；等级为"；Sheet1"；到"0"的列C和D中的第一个空行；片材2"；
复制列E"；名称"；其对应的列F"；等级"；的"；Sheet1"；到"0"的列E和F中的第一个空行；片材2"；
复制列G"；名称"；其对应的列H"；等级"；的"；Sheet1"；到"0"的列G和H中的第一个空行；片材2"；
所以列标题可能是：
列A"；名称"；
列B"；等级"；
列C"；名称"；
列D"；等级"；
列E"；名称"；
列F"；等级"；
列G"；名称"；
列H"；等级"；
示例数据集可能是：
弗雷德80吉姆80鲍勃50鲍勃40
Sam 60 Jason 10 Fred 85 Anna 97
杰森90安娜78安娜65山姆99
等等
将结果复制到"；片材2"；可能是(只是一些例子，不肯定下面的数学是正确的(：
弗雷德80吉姆80鲍勃65安娜97
弗雷德80安娜78弗雷德85山姆99
Sam 60 Jim 80 Fred 85 Anna 97
Sam 60 Anna 78 Bob 50 Sam 99
杰森90吉姆80鲍勃65山姆99
杰森90安娜78弗雷德85山姆99
等等
任何低于250的东西都不会被复制到"；片材2"；
这是我迄今为止的代码。
'<---- **** 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