VBA /复制同一行和上一列中的最大列数和日期，然后粘贴到新表中

Question

I want to find the max of a column and the the date in the same row and previous column and paste into a new sheet.

Please, ignore the comments. I tried over and over just hoping make it work but unfortunately didn't.

Ia appreciate your time and help!!!!!!!

Sub FloodFreqCurve()
'Dim MaxAddr As Variant
Dim MaxN As Integer
Dim rng As Range
Dim i As Integer
Dim Rw As Integer
Dim y As Integer
Dim CopyMax As Range
Dim a As Integer
Dim b As Integer



For i = 2 To 100 Step 2

Worksheets("Discharge").Activate

'MaxN = Worksheets("Discharge").Application.WorksheetFunction.Max(Columns(2))
'Columns(2).Find(MaxN, , xlValues).Row


'This part was from Snakehips
Set rng = Worksheets("Discharge").Columns(i)   'or whatever
Mx = WorksheetFunction.Max(rng)
Rw = WorksheetFunction.Match(Mx, rng, 0) + rng.Row - 1
'-------------------------------


If y = i - 1 > 0 Then
a = Cells(Rw, y).Value
b = Cells(Rw, a).Value


'CopyMax.Copy
'Cells(1, 1).Value = Rw
'Range(Cells(3, 1), Cells(3, 2)).Copy
'Range(
'Cells(Rw, i).Copy ', Cells(Rw, y)).Copy
'Selection.Copy
'CopyMax.Select
'Selection.Copy
'Range("A1").Paste
'MaxAddr = Application.WorksheetFunction.CELL("ADDRESS", Index(Columns(2), Match(Max(Columns(2)), Columns(2), 0)))
'RowNo = Application.WorksheetFunction.Match(Max(Columns(2)), Columns(2))
'MaxAddr.Select
'r = ActiveCell.Row
'ActiveSheet.Range(Cells(r, i), Cells(r - 1, i - 1)).Select
'Worksheets("FLOOD-FREQUENCY CURVE").Activate
'.Paste




End If

Worksheets("FLOOD-FREQUENCY CURVE").Activate
Cells(i, 1).Value = a
Cells(i, 2).Value = b '.PasteSpecial xlPasteAll


Next i

End Sub

Answer 1

I think this will do what you require. You can modify it to fit your needs, but it works fine on my side. The main sub to call is MoveMaxValuesFromColumns() . You will notice that I used if dblTemp >= dblMax then add to max list. this can be changed to only get the maximum once by the following dblTemp > dblMax . Finally, I did the comparison using doubles however, you can modify it to use whatever value you prefer, even variants if you like. I hope this helps.

Option Explicit

Public Sub MoveMaxValuesFromColumns()
    Dim lngI As Long
    Dim strSheet As String
    Dim strCol As String
    Dim strSplit() As String

    Dim strFrom as string
    Dim strTo as string

    strFrom = "Sheet1"
    strTo = "Sheet2"   

    With ThisWorkbook.Worksheets(strFrom)
        For lngI = 2 To 100 Step 2
            strCol = .Cells(1, lngI).Address(ColumnAbsolute:=True)
            'Now, Parse the $'s out to get just the column!
            strSplit = Split(strCol, "$")
            strCol = strSplit(1)

            'call the MoveMax routine 
            MoveMax strCol, strFrom, strTo
        Next lngI
    End With
End Sub

Private Sub MoveMax(strInColumn As String, strFromSheet As String, strToSheet As String)
    Dim rng As Range
    Dim dblMax As Double
    Dim dblTemp As Double
    Dim strMySheet As String
    Dim strTransferSheet As String
    Dim lngLastRow As Long
    Dim lngI As Long
    Dim lngJ As Long
    Dim strOutVals() As String
    Dim strTemp As String
    Dim intCnt As Integer

    Dim lngColOffset As Long

    strMySheet = strFromSheet
    strTransferSheet = strToSheet

    With ThisWorkbook.Worksheets(strMySheet)
        lngColOffset = .Range(strInColumn & ":" & strInColumn).Column

        lngLastRow = .Range(strInColumn & .Range(strInColumn & ":" & strInColumn).Rows.Count).End(xlUp).Row

        Set rng = .Range(strInColumn & "1:" & strInColumn & lngLastRow).Cells

        dblMax = -1.79769313486231E+308  'Set the max to the double precision absolute minimum!
        ReDim strOutVals(0 To (rng.Rows.Count - 1), 0 To 1)
        For lngI = 1 To rng.Rows.Count
            strTemp = rng.Cells(lngI, 1).Value
            If IsNumeric(strTemp) Then
                dblTemp = CDbl(strTemp)
                If dblTemp >= dblMax Then
                    dblMax = dblTemp
                End If
            End If
        Next lngI

        'Now, loop through again and get the max's
        intCnt = 0
        For lngI = 1 To rng.Rows.Count
            strTemp = rng.Cells(lngI, 1).Value
            If IsNumeric(strTemp) Then
                dblTemp = CDbl(strTemp)
                If dblTemp >= dblMax Then
                    strOutVals(intCnt, 1) = rng.Cells(lngI, 1).Value
                    strOutVals(intCnt, 0) = rng.Cells(lngI, 1).Offset(0, -1).Value
                    intCnt = intCnt + 1
                End If
            End If
        Next lngI
    End With

    'Finally, Write out to new Sheet
    With ThisWorkbook.Worksheets(strTransferSheet)
        For lngI = 0 To (intCnt - 1)
            For lngJ = 0 To UBound(strOutVals, 2)  'This is just 1
                .Cells(lngI + 1, lngColOffset + lngJ - 1).Value = strOutVals(lngI, lngJ)
            Next lngJ
        Next lngI
    End With

    Set rng = Nothing

End Sub

Answer 2

Option Explicit

Sub test()

    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim LastRow1 As Long, LastCol1 As Long, LastRow2 As Long, Column As Long, Row As Long
    Dim iDate As Date
    Dim Amount As Double

    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")

    LastCol1 = ws1.Cells(2, ws1.Columns.Count).End(xlToLeft).Column

    For Column = 10 To LastCol1 Step 2

        With ws1

            LastRow1 = .Cells(.Rows.Count, Column).End(xlUp).Row

            Amount = 0
            iDate = Empty

                For Row = 3 To LastRow1

                    If .Cells(Row, Column).Value > Amount Then
                        Amount = .Cells(Row, Column).Value
                        iDate = .Cells(Row, Column - 1).Value
                    End If

                Next Row

        End With

        With ws2

            LastRow2 = .Cells(.Rows.Count, "A").End(xlUp).Row

            .Range("A" & LastRow2 + 1).Value = iDate
            .Range("B" & LastRow2 + 1).Value = Amount

        End With

    Next Column

End Sub