Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - szukanie po wielu arkuszach

Kiluk · Exceloholic **Pomógł:** 6 razy Posty: 249

Witajcie. Znalazłem na forum taki fajny plik.
Potrzebuje "tylko" przerobić szukanie w 1 arkuszu na szukanie we wszystkich arkuszach skoroszytu.

kiluk

SZUKAJKa_1.zip

Pobierz Plik ściągnięto 20 raz(y) 178.16 KB

tkuchta1 · Excel Expert **Pomógł:** 1495 razy Posty: 2270

trochu inaczej

Kod:

Option Explicit

Sub Szukaj2()
Dim xlForm As Excel.Worksheet, ostForm As Long
Dim xlWks As Excel.Worksheet, ostDane As Long
Dim arWks As Variant: arWks = VBA.Array("Dane", "Dane2")
Dim i As Integer

Dim RngS As Excel.Range
Dim RngCrit As Excel.Range

Set xlForm = ThisWorkbook.Worksheets("Formularz")
With xlForm
ostForm = Last(.Columns("A:J"))
If ostForm > 8 Then .Range("A8:J" & ostForm).Clear
Set RngCrit = .Range("A1").CurrentRegion
End With

Application.ScreenUpdating = False

For i = 0 To UBound(arWks)
ostForm = Last(xlForm.Columns("A:J")) + 1

Set RngS = ThisWorkbook.Worksheets(CStr(arWks(i))).Range("A2").CurrentRegion
RngS.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=RngCrit, _
CopyToRange:=xlForm.Range("A" & ostForm), _
Unique:=False

xlForm.Rows(ostForm).Delete
Next

Application.ScreenUpdating = True

Set RngS = Nothing
Set xlForm = Nothing
End Sub

Function Last(rng As Excel.Range) As Long
' wg. Ron de Bruin, 20 Feb 2007
' http://www.rondebruin.nl/last.htm
On Error Resume Next
Last = rng.Find(what:="*", _
After:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

Kiluk · Exceloholic **Pomógł:** 6 razy Posty: 249

oczywiście tkuchta1 (Tomku) wszystko działa jak należy

Dzięki wielkie.
punkt frunie

A gdyby tak...... arkusze "Dane" były w kilku plikach, czyli plik z arkuszem "szukaj" oddzielnie a arkusze "dane" porozrzucane w wielu plikach, a każdy plik z 1 lub wieloma arkuszami (oczywiście każdy w tym samy układzie danych) i wszystkie pliki w 1 folderze. ??

Kiluk