Czy taki kod będzie wystarczający?
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
Pozdrawiam |