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 **** ---->
CodePudding user response：
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(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
EDIT
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