Office: Autofilter und in ander Tabelle Kopieren

Hallo Leute,

Ich hab mir hier ein paar Makroideen geholt für einen Sortierung die dringend brauche. Hab es auch an meine sache anpassen können.

Jetzt wollte ich mir das ganze noch ein bisschen verbessern nur da scheittere ich dran!

Ich will für das Makro die Tabelle in die Kopiert werden soll einen Wert vorgeben der in Zelle AF1 Steh.
Eiso der Tabellenname in die ich die sortierten Werte kopieren will steht in AF1,
wie muss ich das machen?

Code:

:)

 

Hi,

sollte klappen.

Private Sub CommandButton1_Click()
Dim objSh As Worksheet
Dim rngCell As Range
Dim lngCounter As Long
Dim lngAimRow As Long
Dim varColFrom As Variant
Dim varColTo As Variant


varColFrom = Array("A", "B", "c", "d", "e", "f", "g", "h", "i", "j", "k", "z", _
"Aa", "Ab", "Ac", "Ad", "Ae", "Af", "Ag")
varColTo = Array("A", "B", "c", "d", "e", "f", "g", "h", "i", "j", "k", "z", _
"Aa", "Ab", "Ac", "Ad", "Ae", "Af", "Ag")

With Me

Set objSh = Sheets(.Range("Af1").Text)

.Rows(1).AutoFilter Field:=32, Criteria1:=.Range("Af1")

On Error Resume Next
lngAimRow = objSh.Cells(Rows.Count, "A").End(xlUp).Row

For Each rngCell In .Range("AF6:AF" & .Cells(Rows.Count, _
"AF").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
lngAimRow = lngAimRow + 1
For lngCounter = LBound(varColFrom) To UBound(varColFrom)
objSh.Cells(lngAimRow, varColTo(lngCounter)).Value = _
.Cells(rngCell.Row, varColFrom(lngCounter))
Next lngCounter
Next rngCell
End With

If Err <> 0 Then
MsgBox "keine Datensätze gefunden!", vbInformation, "Hinweis"
End If

End Sub

 

Ja cool danke für die Schnelle hilfe!

 

Hallo,

Eiso so funktioniert das Makro schon sehr gut!
Ich hätte jetzt da nur noch ein Problem und zwar,
Ich habe für die Zelle "AF1" 7 verschiedene Variablen, zB sag ich mal Variable 1 = Maier, Variable 2 = Huber, Variable 3 = Ich, das heist ich muss das Makro 7 mal hintereinander Ausführen um meine Daten zu sortieren.

Kann ich das irgendwie in eine Schleife einbaun das er alle 7 durchläufe auf einmal macht?

 

Hi,

auf die Schnelle und ungetestet.

Private Sub CommandButton1_Click()
Dim objSh As Worksheet
Dim rngCell As Range
Dim lngCounter As Long
Dim lngAimRow As Long
Dim varColFrom As Variant
Dim varColTo As Variant
Dim lntList As Variant, lngIndex As Long

varColFrom = Array("A", "B", "c", "d", "e", "f", "g", "h", "i", "j", "k", "z", _
"Aa", "Ab", "Ac", "Ad", "Ae", "Af", "Ag")
varColTo = Array("A", "B", "c", "d", "e", "f", "g", "h", "i", "j", "k", "z", _
"Aa", "Ab", "Ac", "Ad", "Ae", "Af", "Ag")

With Me

.Rows(1).AutoFilter

vntlist = UniqueList(.Range("AF6:AF" & .Cells(Rows.Count, "AF").End(xlUp).Row))

For lngIndex = LBound(vntlist) To UBound(vntlist)

.Range("AF1") = vntlist(lngIndex)

Set objSh = Sheets(.Range("Af1").Text)

.Rows(1).AutoFilter Field:=32, Criteria1:=.Range("Af1")

On Error Resume Next
lngAimRow = objSh.Cells(Rows.Count, "A").End(xlUp).Row

For Each rngCell In .Range("AF6:AF" & .Cells(Rows.Count, _
"AF").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
lngAimRow = lngAimRow + 1
For lngCounter = LBound(varColFrom) To UBound(varColFrom)
objSh.Cells(lngAimRow, varColTo(lngCounter)).Value = _
.Cells(rngCell.Row, varColFrom(lngCounter))
Next lngCounter
Next rngCell
Next
End With

If Err <> 0 Then
MsgBox "keine Datensätze gefunden!", vbInformation, "Hinweis"
End If

End Sub

Function UniqueList(Matrix As Range) As Variant
Dim objDic As Object, rng As Range, varTmp() As Variant

Set objDic = CreateObject("Scripting.Dictionary")

For Each rng In Matrix
If rng.Value <> "" Then objDic(rng.Value) = 0
Next

varTmp = objDic.keys

UniqueList = varTmp

Set objDic = Nothing
End Function

 

Ja es läuft schon fast!

Eiso bei Excel 2007 läuft es ganz gut aber bei Excel 2003 macht er mir immer ein Kriterium Doppelt.

Woran könnte das liegen?