home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2003 October / PCWELT_10_2003.ISO / pcwsoft / PCWFilter.z.exe / PCWFilter.bas next >
Encoding:
BASIC Source File  |  2003-08-06  |  2.5 KB  |  91 lines
  1. Attribute VB_Name = "Modul11"
  2. Public Suchstring, spalte1, spalte2, spalte3 As String
  3. Sub BlattFiltern()
  4. Attribute BlattFiltern.VB_Description = "Makro am 06.08.2003 von F.O.D. aufgezeichnet"
  5. Attribute BlattFiltern.VB_ProcData.VB_Invoke_Func = " \n14"
  6. Dim filter_1(10000)
  7. Dim filter_2(10000)
  8. Dim filter_3(10000)
  9. UserForm1.Show
  10.  
  11. If Suchstring = "" Then
  12.     MsgBox "Die Eingabe des Suchbegriffs ist notwendig."
  13.     Exit Sub
  14. End If
  15.  
  16. If spalte1 = "" Then
  17.     MsgBox "Die Eingabe der Suchspalte ist notwendig."
  18.     Exit Sub
  19. Else
  20.     sp1 = Asc(UCase(spalte1)) - 64
  21.     If sp1 < 1 Then
  22.         MsgBox "Spalten bitte mit Buchstaben (A, B, C...) angeben."
  23.         spalte1 = ""
  24.         Exit Sub
  25.     End If
  26. End If
  27.  
  28. If spalte2 <> "" Then sp2 = Asc(UCase(spalte2)) - 64
  29. If spalte3 <> "" Then sp3 = Asc(UCase(spalte3)) - 64
  30.  
  31. If sp2 < 0 Or sp3 < 0 Then
  32.     MsgBox "Spalten bitte mit Buchstaben (A, B, C...) angeben."
  33.     spalte2 = ""
  34.     spalte3 = ""
  35.     Exit Sub
  36. End If
  37.  
  38. Suchstring = UCase(Suchstring)
  39. For Each tabelle In ActiveWorkbook.Sheets
  40.     If Not tabelle.Name = "PCW-Filter" Then
  41.         tabelle.Select
  42.         zeile = ActiveCell.SpecialCells(xlLastCell).Row
  43.         For x = 1 To zeile
  44.             inhalt = UCase(Cells(x, sp1).Value)
  45.             If InStr(inhalt, Suchstring) Then
  46.                 y = y + 1
  47.                 filter_1(y) = Cells(x, sp1).Value
  48.                 If spalte2 <> "" Then filter_2(y) = Cells(x, sp2).Value
  49.                 If spalte3 <> "" Then filter_3(y) = Cells(x, sp3).Value
  50.             End If
  51.         Next
  52.     End If
  53. Next
  54.  
  55. For Each wsheet In Worksheets
  56.     If wsheet.Name = "PCW-Filter" Then
  57.         Sheets("PCW-Filter").Select
  58.         Columns("A:C").Select
  59.         Selection.ClearContents
  60.         deldone = 1
  61.     End If
  62. Next
  63.  
  64. If deldone = 0 Then
  65.     Set neu = Worksheets.Add
  66.     neu.Name = "PCW-Filter"
  67.     Sheets("PCW-Filter").Select
  68. End If
  69.  
  70. Range("A1:C2").Select
  71. With Selection.Font
  72.     .Size = 14
  73.     .Bold = True
  74. End With
  75. Cells(1, 1).Value = "Suche in Spalte " & UCase(spalte1) & ": " & Suchstring
  76. If spalte2 <> "" Then Cells(1, 2).Value = "Spalte " & UCase(spalte2)
  77. If spalte3 <> "" Then Cells(1, 3).Value = "Spalte " & UCase(spalte3)
  78. For z = 1 To y
  79.     Cells(z + 2, 1).Value = filter_1(z)
  80.     If spalte2 <> "" Then Cells(z + 2, 2).Value = filter_2(z)
  81.     If spalte3 <> "" Then Cells(z + 2, 3).Value = filter_3(z)
  82. Next
  83. Range("A:C").Columns.AutoFit
  84. Range("A1").Select
  85. Suchstring = ""
  86. spalte1 = ""
  87. spalte2 = ""
  88. spalte3 = ""
  89. deldone = 0
  90. End Sub
  91.