VBA / Скопируйте Макс столбца и дату в той же строке и в предыдущем столбце и вставьте в новый лист

Question

Я хочу найти максимум столбца и дату в той же строке и предыдущем столбце и вставить в новый лист.

Пожалуйста, игнорируйте комментарии.Я пытался снова и снова, просто надеясь, что это сработает, но, к сожалению, не получилось.

Я ценю ваше время и помощь !!!!!!!

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

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

Answer 2

Я думаю, что это будет делать то, что вам нужно.Вы можете изменить его под свои нужды, но он отлично работает на моей стороне.Основной сабс для вызова - MoveMaxValuesFromColumns().Вы заметите, что я использовал, если dblTemp >= dblMax, то добавить в список макс.это может быть изменено, чтобы получить максимум только один раз следующим dblTemp > dblMax.Наконец, я сделал сравнение, используя double, однако вы можете изменить его, чтобы использовать любое значение, которое вы предпочитаете, даже варианты, если хотите.Надеюсь, это поможет.

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