PDA

View Full Version : [SOLVED:] Search different sheets



Pinokkio
05-17-2010, 12:44 PM
Hi,
With this macro I can search on one sheet "Monday".
Is it posible to search on the other days of the week?

I try to change the line in to

wsData As Worksheets
Set wsData = Sheets("Monday" , "Tuesday")
But this don't work?




Sub TabsKopie()
Dim dic As Object, x, y, i As Long, r As Range
Dim WS As Worksheet, wsData As Worksheet
Set dic = CreateObject("Scripting.Dictionary")
Set wsData = Sheets("Monday")
With wsData
For Each r In .Range("c3", .Range("c65536").End(xlUp))
If Not IsEmpty(r) Then
If Not dic.exists(r.Value) Then
dic.Add r.Value, r.Row & ":" & r.Row
Else
dic(r.Value) = dic(r.Value) & "," & r.Row & ":" & r.Row
End If
End If
Next
End With
x = dic.keys: y = dic.items
For i = LBound(x) To UBound(x)
On Error Resume Next
Set WS = Sheets(CStr(x(i)))
On Error GoTo 0
If WS Is Nothing Then
Set WS = Sheets.Add(after:=Sheets(Sheets.Count))
WS.Name = x(i)
wsData.Range(y(i)).EntireRow.Copy _
WS.Range("a65536").End(xlUp).Offset(1)
End If
Set WS = Nothing
Next
Sheets("Monday").Select
Application.DisplayAlerts = True
End Sub




I hope that someone can give me idea to me. Thanks

GTO
05-17-2010, 03:27 PM
Sub TabsKopie_2()
Dim dic As Object, x, y, i As Long, r As Range
Dim WS As Worksheet, wsData As Worksheet
For Each WS In Worksheets(Array("Maandag", "Dinsdag", "Woensdag", _
"Donderdag", "Vrijdag", "Zaterdag", "Zondag"))
Set dic = CreateObject("Scripting.Dictionary")
Set wsData = WS 'Sheets("Monday")
With wsData
For Each r In .Range("c3", "C" & Application.Max(.Range("c65536").End(xlUp).Row, 3))
If Not IsEmpty(r) Then
If Not dic.exists(r.Value) Then
dic.Add r.Value, r.Row & ":" & r.Row
Else
dic(r.Value) = dic(r.Value) & "," & r.Row & ":" & r.Row
End If
End If
Next
End With
Set WS = Nothing
x = dic.keys: y = dic.items
For i = LBound(x) To UBound(x)
On Error Resume Next
Set WS = Sheets(CStr(x(i)))
On Error GoTo 0
If WS Is Nothing Then
Set WS = Sheets.Add(after:=Sheets(Sheets.Count))
WS.Name = x(i)
End If
wsData.Range(y(i)).EntireRow.Copy _
WS.Range("C65536").End(xlUp).Offset(1, -2)
Set WS = Nothing
Next
Set dic = Nothing
Next
Sheets("Maandag").Select
Application.DisplayAlerts = True
End Sub

GTO
05-17-2010, 03:36 PM
ACK!

I just realized that there's a .DisplayAlerts in there. If you have this shut off someplace prior, it should not be.

Pinokkio
05-18-2010, 11:40 AM
Many thanks, GTO.

P.