Hallo Allemaal
Ik ben na lang zoeken op een macro gekomen die afhankelijk van verschillende crit een grote aantal gegevens filtert. Ik heb hiervoor een tablad data waar alle gegevens ingezet zijn. Hier zitten echter veel kolommen in die niet nodig zijn voor de filtering. Nu zoek ik een manier om kolommen uit dit script te halen. Dit is het script.
Nu kan ik in tabblad data geen kolommen verwijderen. Ik zoek een manier dat ik in de matrix kolommen over kan slaan.
Ik ben na lang zoeken op een macro gekomen die afhankelijk van verschillende crit een grote aantal gegevens filtert. Ik heb hiervoor een tablad data waar alle gegevens ingezet zijn. Hier zitten echter veel kolommen in die niet nodig zijn voor de filtering. Nu zoek ik een manier om kolommen uit dit script te halen. Dit is het script.
Visual Basic:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
| Private Sub CommandButton1_Click() Dim MaxResults As Integer, MyCol As Integer, ResultsRng As String Dim MyRow As Integer, LastDataRow As Integer, DataRng As String Dim CritRow As Integer, CritRng As String, RightCol As Integer Dim TopRow As Integer, BottomRow As Integer, LeftCol As Integer ' the source data MUST be in a worksheet called 'Data' ' *** MODIFY AND SET YOUR OWN RANGES ON THE FOLLOWING DECLARATIONS *** ' cell Data!E2 contains the last row number of data [=COUNT(E4:E100)+3] LastDataRow = Worksheets("data").Range("E2").Value DataRng = "A3:L3" ' range of column headers for Data table CritRng = "A2:L3" ' range of cells for Criteria table ResultsRng = "A4:L4" ' range of headers for Results table MaxResults = 1000 ' any value higher than the number of possible results ' **************** END OF DECLARATIONS ********************* ' fix the data range to incorporate the last row TopRow = Range(DataRng).Row LeftCol = Range(DataRng).Column RightCol = LeftCol + Range(DataRng).Columns.Count - 1 DataRng = Range(Cells(TopRow, LeftCol), Cells(LastDataRow, RightCol)).Address ' fix the results range to incorporate the last row TopRow = Range(ResultsRng).Row LeftCol = Range(ResultsRng).Column RightCol = LeftCol + Range(ResultsRng).Columns.Count - 1 ResultsRng = Range(Cells(TopRow + 1, LeftCol), Cells(MaxResults, RightCol)).Address Range(ResultsRng).ClearContents ' clear any previous results but not headers ResultsRng = Range(Cells(TopRow, LeftCol), Cells(MaxResults, RightCol)).Address ' fix the criteria range and identify the last row containing any items TopRow = Range(CritRng).Row BottomRow = TopRow + Range(CritRng).Rows.Count - 1 LeftCol = Range(CritRng).Column RightCol = LeftCol + Range(CritRng).Columns.Count - 1 CritRow = 0 For MyRow = TopRow + 1 To BottomRow For MyCol = LeftCol To RightCol If Cells(MyRow, MyCol).Value <> "" Then CritRow = MyRow Next Next If CritRow = 0 Then MsgBox "No Criteria detected", "MeadInKent" Else CritRng = Range(Cells(TopRow, LeftCol), Cells(CritRow, RightCol)).Address Debug.Print "DataRng, CritRng, ResultsRng: ", DataRng, CritRng, ResultsRng Worksheets("Data").Range(DataRng).AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Range(CritRng), CopyToRange:=Range(ResultsRng), _ Unique:=False End If Range("A5").Select End Sub |
Nu kan ik in tabblad data geen kolommen verwijderen. Ik zoek een manier dat ik in de matrix kolommen over kan slaan.
[ Voor 0% gewijzigd door Verwijderd op 06-04-2009 17:32 . Reden: codetags! ]
