Anzeige

 Abfrage mit 2 Codes gleichzeitig


josef24

Erfahrenes Mitglied
#1
Ich versuche in einem Arbeitsschritt 2 "Querys" unter zu bringen, also zu verbinden wie z. B. Union all es bei QMF macht. geht das überhaupt ist meine erste Frage. Wenn ja........
Ich möchte einmal Daten kopieren, und im 2ten Schritt spezifische Werte ansprechen, und aufbereiten lassen. (Wurde im Forum schon gelöst)
Kann mir hierfür jemand einen Lösungsansatz bzw. ein Beispiel liefern.

Meine Codes:

1.: Kopieren aus der Stammdatei in die Arbeitsdatei!
Code:
Private Sub Problem()   ' Die Tabelle Zuzahlung
Dim Zeile As Long
Dim ZeileMax As Long
Dim i As Long
'  .AutoFilter 4, 1
With Worksheets("Zuza")
Worksheets("Problem").Range("A1:z430").ClearContents  ' LÖSCHEN der alten Daten???????
Worksheets("ArbTab").Range("a1:a430").Copy Destination:=Worksheets("Problem").Range("a1")    ' Nummer
Worksheets("ArbTab").Range("c1:c430").Copy Destination:=Worksheets("Problem").Range("b1")    ' Name
Worksheets("ArbTab").Range("d1:d430").Copy Destination:=Worksheets("Problem").Range("c1")    ' Vorname
Worksheets("ArbTab").Range("l1:l430").Copy Destination:=Worksheets("Problem").Range("d1")    ' genBis
   Worksheets("ArbTab").Range("n1:n430").Copy
    Worksheets("Problem").Range("e1").PasteSpecial Paste:=xlValues                              ' Tage gültig
   Worksheets("ArbTab").Range("s1:s430").Copy Destination:=Worksheets("Problem").Range("f1")     ' Bemerkung
Worksheets("ArbTab").Range("y1:y430").Copy Destination:=Worksheets("Problem").Range("g1")    ' Zahlung
    ZeileMax = .UsedRange.Rows.Count
    n = 1

    For Zeile = 1 To ZeileMax
        Next Zeile
        End With
End Sub
2.: Auswahl treffen aus kopierten Daten
Code:
Sub test_neu()
Dim a As Long, i As Long
Dim arr As Variant
Dim Header As Boolean
Application.ScreenUpdating = False
a = 1
a = Worksheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Row + 1
With Worksheets("Tabelle1")
    arr = .Range("A1").CurrentRegion
    For i = LBound(arr) + Abs(Header) To UBound(arr)
        If arr(i, 6) Like "*A*" Or arr(i, 7) Like "*a*" Or (arr(i, 8) >= 1 And arr(i, 8) <= 90) Then
            .Rows(i).Copy _
                Destination:=Worksheets("Tabelle2").Rows(a)
            a = a + 1
        End If
    Next i
End With
Application.ScreenUpdating = True
End Sub
 

Yaslaw

n/a
Moderator
#2
1) Was ist QMF?

2) UNION ALL ist SQL. Dein Code hat nix mit SQL zu tun.

3) Diese 2 Methoden basieren auf verschiedenen Tabellen und verschieden Tabellen. Ausser das Beide irgendwelche Werte kopieren sehe ich keinen Zusammenhang

4) Formatiere deine erste Methode in eine lesbare Form
 

josef24

Erfahrenes Mitglied
#3
Danke, erst mal. Du hast natürlich recht. Es ist SQL gewesen, lange her. Ich hatte vielmehr an eine Prozedur gedacht, so kannte ich es in SQL. Daten aus erstem Code in Tabelle ....... kopieren, und mit mit zweiter Methode die Auswahl treffen und abspeichern. Ist das so verständlich? Gruß Josef
 

Yaslaw

n/a
Moderator
#4
Nö. Das ist nicht verständlich.

Und wo ist das Problem? Du hast alle Befehle die du brauchst.
Du hast Befehle zum Kopieren und zum eine Auswahl treffen.

Setz dich hin und versuche mal einen Code dazu zu schreiben. Schau die die F1-Hilfe zu den Befehlen die du nicht kennst an.
 

josef24

Erfahrenes Mitglied
#5
Danke, es gibt sicher eine einfachere Lösung. Stelle dazu mal was hier ein. Ich kopiere bestimmte Spalten in eine neue Tabelle, wobei ich eine gewisse Spalten-Auswahl treffe. Damit könnte ich den kopierten Tabelleninhalt direkt weiter verwenden. Mein Problem ist Fehler "Typenunverträglichkeit",
"Laufzeitfehler13 " und ich kenne keine Möglichkeit dies zu beseitigen. Danke für etwaige Hilfe. Gruß Josef

Code:
Private Sub Problem()   ' Die Tabelle Problem
Dim Zeile As Long
Dim ZeileMax As Long
Dim i As Long
Dim arr As Variant
Application.ScreenUpdating = False
i = 1

        If arr(i, 19) > " " Or (arr(i, 14) >= 1 And arr(i, 14) <= 40) Then

With Worksheets("Problem")
Worksheets("Problem").Range("A1:z430").ClearContents  ' LÖSCHEN der alten Daten???????
Worksheets("ArbTab").Range("a1:a430").Copy Destination:=Worksheets("Problem").Range("a1")    ' Nummer
Worksheets("ArbTab").Range("c1:c430").Copy Destination:=Worksheets("Problem").Range("b1")    ' Name
Worksheets("ArbTab").Range("d1:d430").Copy Destination:=Worksheets("Problem").Range("c1")    ' Vorname
Worksheets("ArbTab").Range("l1:l430").Copy Destination:=Worksheets("Problem").Range("d1")    ' genBis
   Worksheets("ArbTab").Range("n1:n430").Copy
    Worksheets("Problem").Range("e1").PasteSpecial Paste:=xlValues                              ' Tage gültig
Worksheets("ArbTab").Range("s1:s430").Copy Destination:=Worksheets("Problem").Range("f1")     ' Bemerkung
Worksheets("ArbTab").Range("y1:y430").Copy Destination:=Worksheets("Problem").Range("g1")    ' Zahlung
        ZeileMax = .UsedRange.Rows.Count
            i = 1
                For Zeile = 1 To ZeileMax
            Next Zeile
        End With
        End If
End Sub
 

josef24

Erfahrenes Mitglied
#6
Hab es mal etwas verändert, aber es reicht einfach nicht. hier mein zweiter Versuch. Gruß Josef

Code:
Private Sub Problem()   ' Die Tabelle Problem
Dim Zeile As Long
Dim ZeileMax As Long
  Dim i As Long
Dim a As String
Dim arr As Variant
Application.ScreenUpdating = False
a = 1

ThisWorkbook.Worksheets("ArbTab").Activate
If Range("S1:S250").Value >= "*A*" Then
' With Worksheets("Problem")
Worksheets("Problem").Range("A1:z430").ClearContents  ' LÖSCHEN der alten Daten???????
Worksheets("ArbTab").Range("a1:a430").Copy Destination:=Worksheets("Problem").Range("a1")    ' Nummer
Worksheets("ArbTab").Range("c1:c430").Copy Destination:=Worksheets("Problem").Range("b1")    ' Name
Worksheets("ArbTab").Range("d1:d430").Copy Destination:=Worksheets("Problem").Range("c1")    ' Vorname
Worksheets("ArbTab").Range("l1:l430").Copy Destination:=Worksheets("Problem").Range("d1")    ' genBis
   Worksheets("ArbTab").Range("n1:n430").Copy
    Worksheets("Problem").Range("e1").PasteSpecial Paste:=xlValues                              ' Tage gültig
Worksheets("ArbTab").Range("s1:s430").Copy Destination:=Worksheets("Problem").Range("f1")     ' Bemerkung
Worksheets("ArbTab").Range("y1:y430").Copy Destination:=Worksheets("Problem").Range("g1")    ' Zahlung
    '    ZeileMax = .UsedRange.Rows.Count
            a = a + 1
                For Zeile = 1 To ZeileMax
            Next Zeile
        End With
        End If
End Sub
 

josef24

Erfahrenes Mitglied
#8
Danke erst mal. Es wird auf keine Zeile verwiesen. Also allgemeiner Hinweis. Noch eine Anmerkung: Hatte mich im Netz Office und so etwas versucht zu informieren, und da lass ich immer von Spezialfilter einrichten. Weiß nun nicht ob das für mein Anliegen ebenfalls zutrifft. Gruß Josef
 

Yaslaw

n/a
Moderator
#9
Kannst du mir mal sagen was das soll?
Code:
Dim a As String
a = 1
a = a + 1
Und wo wird ZeileMax ermittelt?

Und nochmals. Formatiere deinen Code! Das Ding ist unlesbar!
Ich weigere mich grundsätzlich unformatierten Code zu lesen, weil ich einfach keine Lust habe durch Zählen herauszufinden was wo beginnt und wo endet.
Auch sonst hast du alle meine bisherigen Tipps in den Wind geschlagen. Ich frage mich, warum ich mir überhaupt die Mühe mache deine Copy&Paste Codes weiter anzuschauen.
 

josef24

Erfahrenes Mitglied
#10
Hallo und guten Abend. Ich will mein Problem nochmals in jetzt geänderter Form veröffentlichen. Gestehe, habe in Foren etwas abgekupfert.
Mit dem Daten kopieren bin ich zufrieden, läuft auch. Wo ich aber bis jetzt keine Lösung gefunden habe, ist: Die Daten aus zwei Spalten ausgewählt beim Kopiervorgang korrekt zu übermitteln. Ich habe das Problem mit Auswahl in zwei Spalten schon öfters versucht zu lösen, bisher aber nie mit Erfolg gekrönt.
Eine Spalte, 2 Fragen geht ja, aber aus zwei Spalten, wie gesagt???????
Ich denke mal das ich doch nicht der Einzige sein werde der eine solche Auswahl mal kreieren musste. Habe schon Interesse anderer User mit meiner Frage neugierig gemacht. Hänge mal die Datei an, um ggf. am Beispiel zu testen. Guten Abend und Gruß Josef
 

Anhänge

#11
Makro aufnehmen und schauen was geschrieben wird.
Visual Basic:
Sub Macro2()
    Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$H$6").AutoFilter Field:=6, Criteria1:=">A" , _
        Operator:=xlAnd
    ActiveSheet.Range("$A$1:$H$6").AutoFilter Field:=8, Criteria1:="<50", _
        Operator:=xlAnd
End Sub
Anschliessend unnötiges Entfernen und das ganze testen
Visual Basic:
Sub Macro2()
    Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$H$6").AutoFilter Field:=6, Criteria1:=">A"
    ActiveSheet.Range("$A$1:$H$6").AutoFilter Field:=8, Criteria1:="<50"
End Sub
 

josef24

Erfahrenes Mitglied
#12
Hallo und Danke. Der Filter entspricht natürlich den Vorgaben aus meiner letzten Anfrage, dafür ein Dankeschön. Wahrscheinlich ist es meine Unterlassung, nochmal extra zu erwähnen, das mein Filter die sowohl als auch Funktion haben sollte. Es wäre jede Spalte (6 + 8) zu berücksichtigen die einen Eintrag aufweist. Vielleicht kann der Anhang das verdeutlichen. Es soll ja gleichzeitig der gefilterte Datenumfang in eine neue Tabelle geschrieben werden. (geschieht hiermit auch)
Danke nochmal bis dahin. Gruß Josef
Code:
Sub Wolli()
  
    Dim wsZ As Worksheet

    Set wsZ = Tabelle2
    With Tabelle1.Range("A1:z300")
    Rows("1:1").Select
        Selection.AutoFilter
        ActiveSheet.Range("$A$1:$H$16").AutoFilter Field:=6, Criteria1:=">=a", Operator:=xlOr
        ActiveSheet.Range("$A$1:$H$16").AutoFilter Field:=8, Criteria1:="<=110", Operator:=xlOr
    
            wsZ.Range("A1:Z300").ClearContents
                 With .Parent.AutoFilter.Range
                  .Columns(1).Copy Destination:=wsZ.Range("a1")
                  .Columns(2).Copy Destination:=wsZ.Range("b1")
                  .Columns(3).Copy Destination:=wsZ.Range("c1")
                    .Columns(4).Copy Destination:=wsZ.Range("d1")
                   .Columns(5).Copy Destination:=wsZ.Range("e1")
                   .Columns(6).Copy Destination:=wsZ.Range("f1")
                   .Columns(7).Copy Destination:=wsZ.Range("g1")
                   .Columns(8).Copy
                    wsZ.Range("h1").PasteSpecial Paste:=xlValues
                End With
            .AutoFilter
        End With
    Application.CutCopyMode = False

End Sub
 
#13
Hab mal schnell Google angeworfen und etwas gefunden.
AdvencedFilter: http://www.contextures.com/xladvfilter01.html
Damit kann man auch gleich kopieren!

Angewendet auf dein Problem
Visual Basic:
Sub Macro1()
    Dim wsFilter As Worksheet
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    
    'Worksheets definieren
    Set wsSource = ActiveWorkbook.Worksheets("Tabelle1")
    Set wsTarget = ActiveWorkbook.Worksheets("Tabelle2")
    wsTarget.UsedRange.ClearContents

    'Filtersheet erstellen
    Set wsFilter = ActiveWorkbook.Worksheets.add()
    wsFilter.name = "FILTER"
    
    'Filter erstellen
    'http://www.contextures.com/xladvfilter01.html -> AND vs OR
    
    '  | A         | B           |
    '-----------------------------
    '1 | Bemerkung | Tage gültig |
    '2 | >A        |             |
    '3 |           | <50         |
    
    'Spaltennamen übernehmen
    wsFilter.Range("A1").value = wsSource.Range("F1").value
    wsFilter.Range("B1").value = wsSource.Range("H1").value
    'Bedinungen einfügen. Für OR auf verscheidenen Zeilen
    wsFilter.Range("A2").value = ">A"
    wsFilter.Range("B3").value = "<50"
    
    'Daten filtern und kopieren
    wsSource.UsedRange.AdvancedFilter xlFilterCopy, wsFilter.UsedRange, wsTarget.Range("A1"), False
    
    'Filtersheet wieder löschen
    Application.DisplayAlerts = False
    wsFilter.Delete
    Application.DisplayAlerts = True
End Sub
 

josef24

Erfahrenes Mitglied
#14
Ja, genau so etwas hatte ich gesucht. Hast wohl mit einem speziellen Suchnamen viel bessere Möglichkeiten auswählen können, als es mir möglich war. Dafür vielen vielen Dank. Eine Frage noch: Darf ich jemand anderes auf diese Seite verweisen, der mit ähnlichem Problem beschäftigt war? Nochmals vielen Dank und noch eine schöne Zeit. Herzliche Grüße Josef
 
#15
Das ist ein offenes Forum. Du darfst jeden hierher verweisen. Das ist sogar erwünscht!
Rechts unter jedem Beitrag hat es eine Nummer mit einem Link. In diesem Beispiel #13 . Am besten diesen Link posten, dann führt er direkt zur Lösung.

Googlesuchbegriff: excel autofilter or multiple columns
 

josef24

Erfahrenes Mitglied
#16
Hallo und einen schönen Tag wünsche ich. Wie schon erwähnt, das Programm läuft super. Möchte noch das sich die Tabelle1 zum Abschluss direkt öffnet. Dazu habe ich folgende Ergänzung eingebracht. Damit komme ich aber nicht weiter, weil er mir irgendeine Tabelle1 zeigt, aber nicht die von mir gewollte. Hänge mal den entsprechenden Code- abschnitt an. Danke bis dahin. Gruß Josef
Code:
    'Filtersheet wieder löschen
   Application.DisplayAlerts = False
    wsFilter.Delete
    Application.DisplayAlerts = True
  
       Application.Dialogs(xlDialogOpen).Show "Tabelle1"
            
End Sub
 
#17
Wozu über einen Dialog? Das ist etwa der komplizierteste unbrauchbarste Weg den es gibt.
Tabelle1 ist doch die Variable wsSource.
Dann ists ganz einfach
Code:
wsSource.Select
 

josef24

Erfahrenes Mitglied
#19
Guten Tag und einen schönen Sonntag. Habe mit dem "direkt öffnen" = wsSource.Select dennoch ein Problem. Wenn ich die Tabelle1 ausgeblendet habe, aber dennoch mit der Auswahl die Tabelle1 direkt öffnen will, bringt er den Hinweis: "Laufzeitfehler 1004". Die Methode select für das Objekt "_Worksheet" ist fehlgeschlagen.
Fehler bei "wsTarget.Select". Kann mich jemand hierfür mit einer ggf. Ergänzung unterstützen? Der VBACode ist wie unter #13 geschrieben, lediglich der Satz wsSource.Select ist ergänzt.
Danke und Gruß Josef
 

Zvoni

Erfahrenes Mitglied
#20
Das Worksheet-Objekt hat eine Visible-Eigenschaft-

Visual Basic:
If Not wsSource.Visible Then wsSource.Visible=True
wsSource.Select
 
Anzeige

Neue Beiträge

Anzeige