Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema RefEdit
BildScreenshot zu RefEdit RefEdit-Seite mit Beispielarbeitsmappe aufrufen

Bereich filtern in andere Tabelle kopier

Betrifft: Bereich filtern in andere Tabelle kopier von: Klara
Geschrieben am: 15.09.2020 14:08:40

Hallo ihr Lieben,

ich habe folgendes Problem: In meiner Arbeitsmappe habe ich zwei Tabellen. In Tabelle 2 sind Daten aus einer anderen Datei verknüpft. In Tabelle 1 soll nun eine Auswertung der Daten erfolgen, deswegen will ich sie mir über VBA kopieren lassen.

Mein Problem ist nun dass in Spalte FW nach einer 1 gefiltert werden muss. Wenn eine 1 enthalten ist, sollen die Daten aus Spalte A und Spalten FP bis FV in Tabellenblatt 1 kopiert werden.

Ich habe bereits folgenden code:


Sub DatenKopieren()

Dim i As Long, j As Long
j = 4
For i = 4 To Sheets("Tabelle2").Cells(Rows.Count, 179).End(xlUp).Row
  If Sheets("Tabelle2").Cells(i, 179) = "1" Then
   Range(Cells(i, 172), Cells(i, 178)).Copy _
      Destination:=Sheets("Tabelle1").Range("A11" & j)
    j = j + 1
  End If
Next

End Sub


Leider funktioniert mein filter nicht und es werden einfach alle Zeilen kopiert ob eine 1 enthalten ist oder nicht. Außerdem will ich nur die Werte und nicht die Verknüpfung kopieren.


Ich habe es auch schon über Makro aufnehmen versucht, das ganze funktioniert zwar, aber es _ springt dann von Tabelle zu Tabelle, ich fände es schöner wenn das nicht der Fall wäre.
Sub Daten_Kopieren()
    Sheets("Tabelle2").Select
    ActiveSheet.Range("$A$2:$QP$481").AutoFilter Field:=242, Criteria1:="1"
    Range ("C4:C500" & ActiveSheet.UsedRange.Rows.Count)
    SpecialCells(xlCellTypeVisible).Copy
    Sheets("Tabelle1").Select
    Range("A11").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Tabelle2").Select
    ActiveSheet.Range("$A$2:$QP$481").AutoFilter Field:=242, Criteria1:="1"
    Range("IA5:IG270").Select
    Selection.Copy
    Sheets("Tabelle1").Select
    Range("A11").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub 


Vielleicht lassen sich die beiden Codes irgendwie kombinieren?
Ich wäre euch für eure Hilfe sehr dankbar!

Liebe Grüße
Klara

Betrifft: AW: Bereich filtern in andere Tabelle kopier
von: Beverly
Geschrieben am: 15.09.2020 15:32:46

Hi Klara,

wenn der Inhalt 1, also eine Zahl ist, dann sind die "" fehl am Platze. Um nur die Werte und nicht die Formeln/Verknüpfungen zu kopieren verwendet man PasteSpecial beim Einfügen (Makro ungetestet):
Sub DatenKopieren()
Dim i As Long, j As Long
j = 4
For i = 4 To Sheets("Tabelle2").Cells(Rows.Count, 179).End(xlUp).Row
  If Sheets("Tabelle2").Cells(i, 179) = 1 Then
   Range(Cells(i, 172), Cells(i, 178)).Copy
   Sheets("Tabelle1").Range("A11" & j).PasteSpecial Paste:=xlValues
   j = j + 1
  End If
Next
End Sub

GrußformelBeverly's Excel - Inn

Betrifft: Ergänzung
von: Beverly
Geschrieben am: 15.09.2020 15:36:15

Hi Klara,

außerdem sollte man die Bezüge auf die Tabellenblätter mittels einer With-Anweisung eindeutig gestalten:
Sub DatenKopieren()
Dim i As Long, j As Long
j = 4
With Sheets("Tabelle2")
    For i = 4 To .Cells(Rows.Count, 179).End(xlUp).Row
      If .Cells(i, 179) = 1 Then
       .Range(.Cells(i, 172), .Cells(i, 178)).Copy
       Sheets("Tabelle1").Range("A11" & j).PasteSpecial Paste:=xlValues
       j = j + 1
      End If
    Next
End With
End Sub

GrußformelBeverly's Excel - Inn

Betrifft: AW: Ergänzung
von: Klara
Geschrieben am: 16.09.2020 10:44:13

Hi Beverly,

das hat perfekt funktioniert!
Vielen lieben Dank für die rasche Unterstützung.

Gibt es noch die Möglichkeit, dass je nach dem Was in Spalte D4 Tabelle1 steht (hier steht die Kalenderwoche welche ich betrachten möchte) das Makro sich die Daten in der entsprechenden Spalte in Tabelle2 sucht?

Beispiel wenn KW25 dann soll der Code in Spalte 179 nach einer 1 suchen und die Werte von 7 Spalten nebendran kopieren, wenn es KW26 ist dann, soll er in Spalte 187 suchen und die 7 Werte nebendran kopieren und so weiter.

Wenn ich z.B. in der Tabelle2 in der ersten Zelle der jeweiligen Spalte stehen habe um welche KW es sich handelt. Sodass das ganze etwas flexibler gestaltet werden könnte.

Viele Grüße
Klara

Betrifft: AW: Ergänzung
von: Beverly
Geschrieben am: 16.09.2020 10:59:01

Hi Klara,

wie ist denn festgelegt, welche KW welcher Zahl entspricht? Wäre es nicht einfacher, gleich die Nummer der KW zu verwenden?

Vom Prinzip kannst du anstelle der 1 den gewünschten Wert aus Zelle D4 wie folgt entnehmen:
If .Cells(i, 179) = Worksheets("Tabelle1").Range("D4") Then

GrußformelBeverly's Excel - Inn

Betrifft: AW: Ergänzung
von: Klara
Geschrieben am: 16.09.2020 11:37:29

Hi Beverly,

ich glaube ich habe mich falsch ausgedrückt.
Es soll immer nach der 1 gesucht werden, aber die KW soll bestimmen in welcher Spalte gesucht wird.

Beispiel:
Wenn KW1 dann soll der Code in Spalte 11 nach einer 1 suchen und die Werte von 7 Spalten nebendran kopieren, wenn es KW2 ist dann, soll er in Spalte 19 suchen und die 7 Werte nebendran kopieren und so weiter.

Ich habe eine Beispiel Datei hochgeladen und hoffe, dass es das Ganze verständlicher macht.
https://www.herber.de/bbs/user/140262.xlsm

Grüße
Klara

Betrifft: Lösungsvorschlag
von: Beverly
Geschrieben am: 16.09.2020 12:02:55

Hi Klara,

ich nehme an du meinst das so:
Sub DatenKopieren()
    Dim i As Long, j As Long, rngSpalte As Range
    j = 4
    With Sheets("Tabelle2")
        Set rngSpalte = .Rows(2).Find(Worksheets("Tabelle1").Range("D4"), lookat:=xlWhole)
        If Not rngSpalte Is Nothing Then
            For i = 4 To .Cells(Rows.Count, 3).End(xlUp).Row
              If .Cells(i, rngSpalte.Column) = 1 Then
               Union(.Cells(i, 3), .Range(.Cells(i, rngSpalte.Column + 1), _
                .Cells(i, rngSpalte.Column + 7))).Copy
               Sheets("Tabelle1").Range("A" & j + 2).PasteSpecial Paste:=xlValues
               j = j + 1
              End If
            Next
        Else
            MsgBox "KW nicht gefunden"
        End If
    End With
End Sub

GrußformelBeverly's Excel - Inn

Betrifft: Funktioniert perfekt
von: Klara
Geschrieben am: 16.09.2020 12:33:48

Hi Beverly,

das ist genial!
Ich kann dir gar nicht genug Danken.

Viele Grüße
Klara

Beiträge aus dem Excel-Forum zum Thema "Bereich filtern in andere Tabelle kopier"