Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1180to1184
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Kopieren, wenn Wert

Kopieren, wenn Wert
Claudia
Hallo zusammen,
aufbauend auf diesem Makro suche ich eine Lösung, wie ich die roten TAbellen befüllt bekomme.
Private Sub Neuanlage_Person_für_alle_roten_Reiter()
Dim Blatt As Worksheet
For Each Blatt In ActiveWorkbook.Worksheets
If Blatt.Tab.ColorIndex = 3 Then
Blatt.Select
Range("a65536").End(xlUp).Select
ActiveCell.Offset(1, 0).Select
'run "kopieren"
End If
Next Blatt
ActiveWorkbook.Save
End Sub

Die gesamte Datenmenge befindet sich im Reiter "Daten", der keine Farbe trägt. Nun will ich in jedes rote Blatt nur die Daten kopieren, die für dieses Blatt bestimmt sind.
Der zu prüfende Wert befindet sich in den roten Blättern immer an der gleichen Stelle nämlich in Zelle N1.
Aus dem Reiter "Daten" sollen nun die gesammte Zelle kopiert werden, wenn
Zelle J der betreffenden Zeile mit dem Wert N1 aus dem roten Blatt übereinstimmt.
Im Reiter Daten soll diese Zeile dann gelöscht werden.
Wer kann mir hierbei helfen?
LG und vielen Dank!
Claudia

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Kopieren, wenn Wert
10.10.2010 19:20:48
Josef

Hallo Claudia,
lade eine Beispieldatei hoch.

Gruß Sepp

AW: Kopieren, wenn Wert
10.10.2010 20:10:42
Josef

Hallo Claudia,
probier mal diesen Code.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub arrangeData()
  Dim lngLast As Long, lngNext As Long
  Dim vntValues As Variant
  Dim rng As Range, rngDel As Range
  Dim lngIndex As Long, lngN As Long
  Dim strSearch As String
  Dim objSh As Worksheet
  
  
  With Sheets("Daten")
    lngLast = Application.Max(4, .Cells(Rows.Count, 1).End(xlUp).Row)
    vntValues = .Range(.Cells(4, 10), .Cells(lngLast, 10))
    For Each objSh In ThisWorkbook.Worksheets
      If objSh.Tab.ColorIndex = 3 Then
        strSearch = objSh.Range("N1")
        Set rng = Nothing
        lngNext = Application.Max(4, objSh.Cells(Rows.Count, 1).End(xlUp).Row + 1)
        lngN = 0
        For lngIndex = 1 To UBound(vntValues, 1)
          If vntValues(lngIndex, 1) = strSearch Then
            If rng Is Nothing Then
              Set rng = .Range(.Cells(lngIndex + 3, 1), .Cells(lngIndex + 3, 10))
            Else
              Set rng = Union(rng, .Range(.Cells(lngIndex + 3, 1), .Cells(lngIndex + 3, 10)))
            End If
          End If
        Next
        If Not rng Is Nothing Then
          rng.Copy objSh.Cells(lngNext, 1)
          If rngDel Is Nothing Then
            Set rngDel = rng.EntireRow
          Else
            Set rngDel = Union(rngDel, rng.EntireRow)
          End If
        End If
      End If
    Next
    If Not rngDel Is Nothing Then rngDel.Delete
  End With
  
  Set rngDel = Nothing
  Set rng = Nothing
End Sub

Gruß Sepp

Anzeige
AW: Kopieren, wenn Wert
10.10.2010 21:17:46
Claudia
Hallo Sepp,
funktioniert einwandfrei. Vielen Dank!
Claudia
Noch eine Frage
13.10.2010 14:36:01
Claudia
Hallo Sepp,
wo muss ich den Code ändern, wenn die gesamte Zeile kopiert werden soll (und bim Blatt Daten dann gelöscht).
Vielen Dank!
Viele Grüße
Claudia
Zweite Frage
13.10.2010 14:41:14
Claudia
Hallo Sepp,
wo muss ich den Code ändern, wenn die gesamte Zeile kopiert werden soll (und bim Blatt Daten dann gelöscht).
Und wo muss ich den Code ändern, wenn sich der Suchbegriff z.B. in Spalte K befindet.
Nochmals vielen Dank!
Viele Grüße
Claudia
AW: Zweite Frage
13.10.2010 19:45:29
Josef

Hallo Claudia,
das geht so.

Sub arrangeData()
  Dim lngLast As Long, lngNext As Long
  Dim vntValues As Variant
  Dim rng As Range, rngDel As Range
  Dim lngIndex As Long, lngN As Long
  Dim strSearch As String
  Dim objSh As Worksheet
  
  
  With Sheets("Daten")
    lngLast = Application.Max(4, .Cells(Rows.Count, 1).End(xlUp).Row)
    vntValues = .Range(.Cells(4, 10), .Cells(lngLast, 10))
    For Each objSh In ThisWorkbook.Worksheets
      If objSh.Tab.ColorIndex = 3 Then
        strSearch = objSh.Range("N1")
        Set rng = Nothing
        lngNext = Application.Max(4, objSh.Cells(Rows.Count, 1).End(xlUp).Row + 1)
        lngN = 0
        For lngIndex = 1 To UBound(vntValues, 1)
          If vntValues(lngIndex, 1) = strSearch Then
            If rng Is Nothing Then
              Set rng = .Rows(lngIndex + 3)
            Else
              Set rng = Union(rng, .Rows(lngIndex + 3))
            End If
          End If
        Next
        If Not rng Is Nothing Then
          rng.Copy objSh.Cells(lngNext, 1)
          If rngDel Is Nothing Then
            Set rngDel = rng
          Else
            Set rngDel = Union(rngDel, rng)
          End If
        End If
      End If
    Next
    If Not rngDel Is Nothing Then rngDel.Delete
  End With
  
  Set rngDel = Nothing
  Set rng = Nothing
End Sub

Gruß Sepp

Anzeige
Laufzeitfehler 13
13.10.2010 20:58:20
Claudia
Hallo Sepp,
ich bekomme einen Laufzeitfehler "Typen unverträglich".
Er belibt im Code stehen in Zeile :
For lngIndex = 1 To UBound(vntValues, 1)
Die andere Frage. Wenn sich der Suchbegriff in Spalte K befindet, müsste ich dann
vntValues = .Range(.Cells(4, 10), .Cells(lngLast, 10))
durch
vntValues = .Range(.Cells(4, 11), .Cells(lngLast, 11)) ersetzen?
Claudia
Hat sich erledigt der Fehler. Danke!
13.10.2010 21:04:09
Claudia
AW: Laufzeitfehler 13
13.10.2010 21:14:41
Josef

Hallo Claudia,
der fehler kann eigentlich nur kommen, wenn "Daten" leer ist.
Probier mal den angepassten Code.
Und ja, wenn der Suchbegriff in Spalte K steht, musst du die 10 durch die 11 ersetzen.

Sub arrangeData()
  Dim lngLast As Long, lngNext As Long
  Dim vntValues As Variant
  Dim rng As Range, rngDel As Range
  Dim lngIndex As Long, lngN As Long
  Dim strSearch As String
  Dim objSh As Worksheet
  
  
  With Sheets("Daten")
    lngLast = Application.Max(4, .Cells(Rows.Count, 1).End(xlUp).Row)
    vntValues = .Range(.Cells(4, 10), .Cells(lngLast, 10))
    If Not IsArray(vntValues) Then
      Redim vntValues(1 To 1, 1 To 1)
      vntValues(1, 1) = .Cells(4, 10)
    End If
    For Each objSh In ThisWorkbook.Worksheets
      If objSh.Tab.ColorIndex = 3 Then
        strSearch = objSh.Range("N1")
        Set rng = Nothing
        lngNext = Application.Max(4, objSh.Cells(Rows.Count, 1).End(xlUp).Row + 1)
        lngN = 0
        For lngIndex = 1 To UBound(vntValues, 1)
          If vntValues(lngIndex, 1) = strSearch Then
            If rng Is Nothing Then
              Set rng = .Rows(lngIndex + 3)
            Else
              Set rng = Union(rng, .Rows(lngIndex + 3))
            End If
          End If
        Next
        If Not rng Is Nothing Then
          rng.Copy objSh.Cells(lngNext, 1)
          If rngDel Is Nothing Then
            Set rngDel = rng
          Else
            Set rngDel = Union(rngDel, rng)
          End If
        End If
      End If
    Next
    If Not rngDel Is Nothing Then rngDel.Delete
  End With
  
  Set rngDel = Nothing
  Set rng = Nothing
End Sub

Gruß Sepp

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige