Mefisto...diabeł czy anioł?
Siemka... Kombinowa³em sam, ale moja wiedza z VBA jest za ma³a abym sam tego dokona³ :P Potrzebne mi makro (koniecznie makro - nie chce filtrowaæ), które przeszuka 1 z góry okre¶lon± kolumnê z arkusza Arkusz1, gdy znajdzie szukan± warto¶æ zaznaczy ca³y rz±d i przekopiuje go do rzêdu 10 w arkuszu Arkusz2. Nastêpnie wyszuka kolejnej warto¶ci, skopiuje ca³y znaleziony rz±d i przekopiuje go do kolejnego wolnego rzêdu z Arkusza Arkusz2. Proszê o pomoc... Sam kombinowa³em jak, a w dowód tego moge zamie¶ciæ skrypt, który jest do niczego :P
Sub szukaj()
Dim a As String
Dim firstAddress As String
a = Cells(5, 2).Value
If a = "" Then Exit Sub
With Cells
Set c = .Find(a, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
If Not c Is Nothing Then
firstAddress = c.Address
If InStr(1, UCase(Range(firstAddress).Value), UCase(a)) > 0 Then
Worksheets("Arkusz1").Cells(firstAddress).Select
Selection.Copy
Worksheets("Arkusz2").Range("A10").EntireRow.Select
ActiveSheet.Paste
End If
Do
Set c = .FindNext(c)
If InStr(1, UCase(Range(c.Address).Value), UCase(a)) > 0 Then
Worksheets("Arkusz1").Cells(firstAddress).EntireRow.Select
Selection.Copy
Worksheets("Arkusz2").Range("A10").EntireRow.Select
ActiveSheet.Paste
End If
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Sub
[ Dodano: 2008-02-19, 23:55 ]
zanotowane.pl doc.pisz.pl pdf.pisz.pl katkaras.opx.pl
Sub szukaj()
Dim a As String
Dim firstAddress As String
a = Cells(5, 2).Value
If a = "" Then Exit Sub
With Cells
Set c = .Find(a, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
If Not c Is Nothing Then
firstAddress = c.Address
If InStr(1, UCase(Range(firstAddress).Value), UCase(a)) > 0 Then
Worksheets("Arkusz1").Cells(firstAddress).Select
Selection.Copy
Worksheets("Arkusz2").Range("A10").EntireRow.Select
ActiveSheet.Paste
End If
Do
Set c = .FindNext(c)
If InStr(1, UCase(Range(c.Address).Value), UCase(a)) > 0 Then
Worksheets("Arkusz1").Cells(firstAddress).EntireRow.Select
Selection.Copy
Worksheets("Arkusz2").Range("A10").EntireRow.Select
ActiveSheet.Paste
End If
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Sub
[ Dodano: 2008-02-19, 23:55 ]