BESTIMMTE ZEILEN IN EINE ANDERE TABELLEN KOPIEREN

[Berndt]

Hallo Excel-Community,

ich bin neu in der VBA Szene und habe ein Code-Problem.

Ich möchte mal zunächst stichpunktartig die Aufgabe des Makros erläutern.

- Im Blatt "Themenspeicher" stehen Themen mit Verantwortlichkeiten und Terminen
- Alle braunen Blätter gehören zu den jeweiligen Mitarbeitern

- per Knopfdruck soll nun das Thema inkl. Termin dem Mitarbeiter zugeordnet werden
- voraussetzung ist, dass das Thema zur Übertragung bereit ist (mit einem "x" gekennzeichnet)

Eine weitere Hürde ist, das der Bereich zum Einfügen in den Mitarbeiterblättern nicht immer gleich ist (er kann sich nach oben und unten verschieben)

Mein Code-Vorschlag, welches aber nur halb funktioniert:

Code:

Private Sub CommandButton3_Click()

Dim Zeile As Long
Dim ZeileMax As Long
Dim n As Long
Dim WST As Worksheet

Set WST = ThisWorkbook.Worksheets("Themenspeicher") ' Worksheet Themenspeicher wird gesetzt
    If WSd.Cells(Zeile, 3).Value = "x" Then
        With Tabelle1
            ZeileMax = .UsedRange.Rows.Count
            n = 1
            
            For Zeile = 2 To ZeileMax
            
            If .Cells(Zeile, 3).Value = "x" Then
    
            .Rows(Zeile).Copy Destination:=Tabelle2.Rows(n)
            n = n + 1
            
            End If
            Next Zeile
        End With
    End If
End Sub

Kann jmd helfen?

Eine Bsp. Datei wie es aussehen sollte habe ich im Anhang.

VG und Danke 
Berndt

[schauan]

Hallo Berndt,

was funktioniert denn an Deinem code nur halb? Für die Fragestellung ist es immer von Vorteil, wenn Du z.B. die Fehlermeldung zitierst und die Zeile, wo das passiert.

Ich würde erst mal sagen, dass da ziemlich oben ein Fehler kommt und sonst nix passiert.

In dieser Zeile
If WSd.Cells(Zeile, 3).Value = "x" Then

ist die Variable Zeile noch nicht belegt, dort rechnet Excel mit 0 und eine Zeile 0 gibt es nicht
WSd gibt es ebenfalls nicht. Darüber hast Du WSt festglegt.

Da ist es von Vorteil, wenn Du mit der Überwachung arbeitest. Stelle den Cursor mal in das Wort Zeile, klicke mit der rechten Maustaste und wähle "Überwachung hinzufügen". Dann siehst Du im Überwachungsfenster Daten zur Variable.
Für die Fehlermeldung kannst Du übrigens unten auch wieder über das Mausmenü eine Überwachung hinzufügen und gibst im Dialog err ein. Dann hast Du im Überwachungsfenster einen weiteren Ausdruck, und wenn Du err aufklappst, siehst Du z.B. die Fehlernummer und die Beschreibung.

Weiter unten hast Du in einer Schleife nochmal diese Prüfung, jedoch ohne WSd bzw. WSt. An dieser Stelle passt das besser.

Hast Du eigentlich mehrere Zeilen mit x gekennzeichnet?

Wenn nicht, dann könntest Du nach dem Kopieren gleich die Schleife mit "Exit For" verlaassen. Ist aber zweitrangig für die Funktion.

Die Trefferzeile wird immer eine Zeile oberhalb in die Tabelle2 eingetragen. Hast Du einen Treffer in Zeile 23, kommt diese Zeile nach Zeile 22 in Tabelle2. Das steuerst Du mit dem n.

Jetzt ist die Frage, was mit dem veränderlichen Bereich gemeint ist. Das muss man Excel ja genau mitteilen bzw. eine entsprechende Bedingung oder Vorgehensweise daraus ableiten. Man könnte z.B. sagen, hänge den Treffer an die vorhandenen Daten in Tabelle2 an. Oder man sagt, überschreibe die erste Zeile, die in Spalte A den gleichen Inhalt hat.

[Rabe]

Hi Berndt,

Kann jmd helfen?

ich habe Dein Makro mal etwas umgestellt und die Variablen etwas sprechender gemacht. Die If-Schleife ist nicht notwendig, bzw. führt zu einem falschen Ergebnis: wenn in der loZeile kein "x" steht, dann wird die WITH gar nicht mehr gestartet!

Private Sub CommandButton3_Click()
  ' Thema an MA übertragen 
  Dim loZeile As Long
  Dim loZeileMax As Long
  Dim n As Long
  Dim WST As Worksheet
  
  Set WST = ThisWorkbook.Worksheets("Themenspeicher") ' Worksheet Themenspeicher wird gesetzt 
  '   loZeile = 6 
  '   If WST.Cells(loZeile, 3).Value = "x" Then       ' die If-Schleife wird doch gar nicht benötigt? 
  With WST
     loZeileMax = .UsedRange.Rows.Count
     n = 1
     For loZeile = 6 To loZeileMax
        If .Cells(loZeile, 3).Value = "x" Then
           .Rows(loZeile).Copy Worksheets("Dashboard").Rows(n)
           n = n + 1
        End If
     Next loZeile
  End With
  '   End If 
  
End Sub

VBA/HTML - CodeConverter für Office-Foren, AddIn für Excel/Word 2000-2013 - komplett in VBA geschrieben von Lukas Mosimann. Projektbetreuung durch mumpel
Code erstellt und getestet in Office 15

Diese Aussage verstehe ich aber nicht:

Die Trefferzeile wird immer eine Zeile oberhalb in die Tabelle2 eingetragen. Hast Du einen Treffer in Zeile 23, kommt diese Zeile nach Zeile 22 in Tabelle2. Das steuerst Du mit dem n.

Es wird mit dem n immer nur beginnend in Zeile 1 des Dashboards das Thema eingetragen.
Die Spaltenzahl des Themenspeichers stimmt nicht überein mit der Spaltenzahl der Themen im Dashboard!
Es fehlt außerdem noch der Code-Teil, der die Themen in die zugeordneten MA-Blätter überträgt, ans Ende der dortigen Themen.

Hier ein funktionierender Code für den Übertrag in das Dashboard:

Private Sub CommandButton3_Click()
   ' Thema an MA übertragen 
   Dim loZeile As Long
   Dim loZeileMax As Long
   Dim WSd As Worksheet
   Dim LastWsD As Long
   Dim loWsD As Long
   Dim n As Long
   Dim WST As Worksheet
   
   Set WST = ThisWorkbook.Worksheets("Themenspeicher")   ' Worksheet Themenspeicher wird gesetzt 
   Set WSd = ThisWorkbook.Worksheets("Dashboard")        ' Worksheet Dashboard wird gesetzt 
   With WSd
      LastWsD = .Cells(1048576, 2).End(xlUp).Row         ' Letzte gefüllte Zelle auf dem Dashboard in Spalte B (2) 
      loWsD = .Range("B" & LastWsD).End(xlUp).Row        ' feststellen der obersten Zeile des Themenblockes 
      Range("B" & loWsD & ":F" & LastWsD).Clear
      loWsD = .Range("B" & loWsD).Row + 1                    ' erste Zeile des Eintragsbereichs des Themenblockes 
      With .Range("B" & loWsD & ":E" & LastWsD)
         .ClearContents
         .Borders(xlDiagonalDown).LineStyle = xlNone
         .Borders(xlDiagonalUp).LineStyle = xlNone
         .Borders(xlEdgeLeft).LineStyle = xlNone
         .Borders(xlEdgeTop).LineStyle = xlNone
         .Borders(xlEdgeBottom).LineStyle = xlNone
         .Borders(xlEdgeRight).LineStyle = xlNone
         .Borders(xlInsideVertical).LineStyle = xlNone
         .Borders(xlInsideHorizontal).LineStyle = xlNone
      End With
   End With
   
   With WST
      loZeileMax = .UsedRange.Rows.Count
      
      For loZeile = 6 To loZeileMax
         If .Cells(loZeile, 3).Value = "x" Then
            .Range("B" & loZeile).Copy Worksheets("Dashboard").Range("B" & loWsD)
            .Range("D" & loZeile & ":E" & loZeile).Copy Worksheets("Dashboard").Range("C" & loWsD)
            loWsD = loWsD + 1
         End If
      Next loZeile
   End With
   
End Sub

VBA/HTML - CodeConverter für Office-Foren, AddIn für Excel/Word 2000-2013 - komplett in VBA geschrieben von Lukas Mosimann. Projektbetreuung durch mumpel
Code erstellt und getestet in Office 15

[Berndt]

Hallo,

Danke für eure Antworten.

Ich habe mittlerweile auch weiter daran gearbeitet und benutze folgendes Makro zum Übertrag ins Dashboard:

Code:

Private Sub CommandButton4_Click()

'Themenspeicher

  Dim a
  Dim i         As Long
  Dim k         As Long
  Dim bis       As Long
  Dim ende      As Long
  Dim bisStart  As Long
  Dim von       As Long
  Dim Treffer   As Range
  Dim Start     As Long
  Dim go        As Range
  
  
  Application.ScreenUpdating = False
  
  Set go = Worksheets("Dashboard").Columns(2).Find("*Themenspeicher*", LookIn:=xlValues)
  Start = go.Row + 1  'erste Zelle nach Themenspeicher in Sheet Dashboard
  ende = Worksheets("dashboard").Range("B" & Rows.Count).End(xlUp).Row + 1
  
  With Worksheets("Dashboard").Range("B" & Start & ":G" & ende)
        .Clear
'        .Borders(xlEdgeLeft).ThemeColor = 1
'        .Borders(xlEdgeTop).ThemeColor = 1
'        .Borders(xlEdgeBottom).ThemeColor = 1
'        .Borders(xlEdgeRight).ThemeColor = 1
'        .Borders(xlInsideVertical).ThemeColor = 1
'        .Borders(xlInsideHorizontal).ThemeColor = 1
'        .RowHeight = 12.75
  End With
  
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  
  Set Treffer = Worksheets("Themenspeicher").Columns(2).Find("*Themenspeicher*", LookIn:=xlValues)
' Const  von = 6
  von = Treffer.Row + 1  'erste Zelle nach Themenspeicher in Sheet Themenspeicher
  bis = Worksheets("Themenspeicher").Range("B" & Rows.Count).End(xlUp).Row + 1
  a = Worksheets("Themenspeicher").Range("B" & von & ":E" & bis)
  
  For i = 1 To UBound(a)
    If a(i, 2) = "x" Then
        bis = Sheets("Dashboard").Range("B2000").End(xlUp).Row + 1
        If IsError(Application.Match(a(i, 1), Worksheets("Dashboard").Range("B1:B" & bis), 0)) Then
        
        Sheets("Dashboard").Range("B" & bis) = a(i, 1)
        Sheets("Dashboard").Range("E" & bis) = a(i, 4)
        Sheets("Dashboard").Range("F" & bis) = a(i, 3)
        
        If bisStart = 0 Then bisStart = bis
        
        With Sheets("Dashboard").Range("F" & bis)
            If .Offset(-1).Value <> .Value Then
                With .Offset(, -4).Resize(, 6).Borders(xlEdgeTop)
                    .LineStyle = xlDot 'gepunktete Linie
                    .Weight = xlThin
                End With
            End If
        End With
            
        End If
    End If
  Next
  
  If bisStart > 0 Then
    With Sheets("Dashboard").Range("B" & bisStart & ":G" & bis)
        With .Columns(1).Resize(, 3) 'Verbinden
            .Merge True
            .HorizontalAlignment = xlLeft 'linksbündig
            .BorderAround xlContinuous 'Rahmen
            .Font.Bold = False 'nicht fettgedruckt
            .Font.Size = 9 'Schriftgröße 9
        End With
        With .Columns(4)
            .HorizontalAlignment = xlLeft 'linksbündig
            .BorderAround xlContinuous 'Rahmen
            .Font.Size = 9 'Schriftgröße 9
        End With
        With .Columns(5).Resize(, 2) 'Verbinden
            .Merge True
            .HorizontalAlignment = xlCenter 'linksbündig
            .BorderAround xlContinuous 'Rahmen
            .Font.Size = 9 'Schriftgröße 9
        End With
    End With
  End If
  
  Application.ScreenUpdating = True
End Sub

VG Berndt