Sub test()
Dim ostatnia As String ' ostatnia pełna komórka
Dim wiersz As Long
Dim kolumna As Long
Dim pierwsza As String 'adres pierwszej komórki do skopiowania
Dim druga As String 'adres drugiej komórki do skopiowania
Dim min As Double
Dim maks As Double
min = 2470000
maks = 3575000
ostatnia = Cells.Find(What:="*", _
After:=Cells(1, 1), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

ostatnia = Cells(ostatnia, Cells.Find(What:="*", _
After:=Cells(1, 1), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column).Address


For kolumna = 1 To Range(ostatnia).Column
    For wiersz = 2 To Range(ostatnia).Row
        If Cells(wiersz, kolumna) > min Then pierwsza = Cells(wiersz, kolumna).Address: Exit For
    Next wiersz
    If pierwsza <> "" Then
    For wiersz = Range(pierwsza).Row To Range(ostatnia).Row
        If Cells(wiersz, kolumna) >= maks Then
        druga = Cells(wiersz, kolumna).Offset(-1, 0).Address
        Range(pierwsza, druga).Copy Sheets("Arkusz2").Cells(1, kolumna)
        Exit For
        End If
    Next wiersz
    End If
    
        pierwsza = ""
        druga = ""

Next kolumna
End Sub