Bestimmte Zellen in neue Tabellen kopieren

[Rabe]

Hi Atilla,

Ach so, bevor ich es vergesse: Du solltest nicht nur negatives heraussuchen.
Ab und zu auch mal loben, denn sonst demotiviert es mich. :22:

alles klar. Werde ich zukünftig beachten.

Generell finde ich Deine Engagement und Deine Lösungen hier :18:

[Gast 123]

Hallo an alle Kollegen

denn sonst demotiviert es mich. 

darüber könnte ich einen mehrstündigen (Fach) Vortrag halten. basierend auf über 70 Bücher über Psychologie.
Empfehlenswert die "Individualpsychologie" von Arlfred Adler - vor allem das in der Kindheit anerzogenes Thema:  (auch bei mir!!)
Minderwertigkeitskomplex.   Es dauert lange bis man den überwindet.  Den meisten Menschen ist es nicht einmal bewusst.
Man sieht es oft auf dem Schulhof:  "mein Handy ist aber viel besser als dein Handy,  Ätschi bätschi !!"
Ebenso bei den Erwachsenen (Reklame)   "mein Haus, mein Auto, mein Pferd, meine Yacht - Ätsch!!"  
Liesst man dann das Buch von Karen Horney "Der neurotische Mensch unserer Zeit"  -   weisste Bescheid!!

Abhilfe
Der schnellste Weg:   Erkenne  das du Atilla bist!!  Einfach so, wie du jetzt bist!!  Mehr gibt es nicht zu sagen.
Bewusstsein heisst:    Selbst erkennen was deine Stärken sind, erinnere dich das ich dieine Makros bewundere.
Wissen das man nicht alles kann, dumme Fehler macht.  (Habt ihr bei mir sicher oft genug gelesen)

Akzeptieren
Man weiss was man kann, akzeptiert gelassen, was man -nicht kann-!  Das führt zu innerer Ruhe und Gelassenheit.
In Adana scheint gerade die Sonne. so sollte auch unsere innere Stimmung sein

mfg  Gast 123 

PS  @Atilla  ich versuche gerade drei Katzen den Koran beizubringen.  Ich glaube sie interessieren sich mehr fürs Futter!!  Nun ja .....

[Gast 123]

Hallo

höfliche Frage an den Frager:   Warum muss für jedes Nein eine neue Tabelle erstellt werden??
Könnte man nişcht alle "Nein" in einer Tabelle auflisten?  Den Sinn habe ich noch nicht verstanden.

mfg  Gast 123

[aeugeln87]

Hallo,

unten stehenden Code in ein allgemeines Modul einfügen:

Code:

Sub tabellenAnlegen1()
   Dim i As Long
   Dim j As Long
   Dim k As Long, m As Long
   Dim x
   Dim loLetzte As Long, lngS As Long
   Dim strgText As String
   Dim wks As Worksheet
   Dim arr As Variant
   Dim D1 As Object
   Dim varK
   Set D1 = CreateObject("Scripting.Dictionary")
   On Error GoTo fehler
   Application.ScreenUpdating = False
   
   strgText = "NEIN"
   
   With Worksheets("Teilnehmende-Stammdatenblatt")                       'datentabelle
       loLetzte = IIf(IsEmpty(.Cells(Rows.Count, 1)), .Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
       lngS = .Cells(1, .Columns.Count).End(xlToLeft).Column
       arr = .Range("A1:C" & loLetzte)
       For i = 3 To UBound(arr)
         x = Application.Match(strgText, .Rows(i), 0)
         If IsNumeric(x) Then
           D1(arr(i, 1)) = D1(arr(i, 1)) & "#" & arr(i, 2) & "#" & arr(i, 3) & "#" & x
         End If
       Next i
       
       For Each varK In D1.keys
         Set wks = Worksheets.Add(After:=Sheets(Sheets.Count))
         wks.Name = varK
         wks.Range("A1:B1").Value = .Range("B1:C1").Value
         wks.Range("C1").Value = "Spalte"
         k = 0
         m = 2
         strgText = Replace(D1(varK), "#", "", 1, 1)
         For j = 0 To UBound(Split(strgText, "#")) Step 3
           wks.Cells(m, 1) = Split(strgText, "#")(k)
           wks.Cells(m, 2) = Split(strgText, "#")(k + 1)
           wks.Cells(m, 3) = Replace(Cells(1, Val(Split(strgText, "#")(k + 2))).Address(0, 0), "1", "")
           m = m + 1
           k = k + 3
         Next j
       Next
       .Select                             'am Ende wieder Datentabelle auswählen
   End With
fehler:
   Application.ScreenUpdating = True
   Set wks = Nothing
   D1.RemoveAll
   Set D1 = Nothing
   If Err.Number > 0 Then MsgBox Err.Number & "  " & Err.Description

End Sub

Mit folgendem Code können alle Tabellen bis auf Tabelle "Teilnehmende-Stammdatenblatt" gelöscht und danach kann wieder der obige Code gestartet werden:

Code:

Sub tab_löschen()
Dim j As Integer

   For j = Sheets.Count To 1 Step -1
       If Sheets(j).Name <> "Teilnehmende-Stammdatenblatt" Then
           Application.DisplayAlerts = False
           Sheets(j).Delete
           Application.DisplayAlerts = True
       End If
   Next j
End Sub

Und unten noch einmal Deine Datei mit eingearbeitetem Code:

Hallo atilla,

wow, fast genau so habe ich mir das vorgstellt. Vielen, vielen Dank. Jetzt habe ich aber gesehen, es wird schon über das eine kleine Problem diskutiert   

Ja, es gibt mehrere "NEIN" in einer Zeile und es wäre perfekt, wenn auch alle gefundenen aufgelistet werden. Die abzusuchenden Spalten wären B - DH. Sorry, ich hätte das im Beispiel deutlicher machen sollen. 

Zur Aufklärung, die Tabelle mit JA/NEIN wertet für mich aus, ob der Wert in der Quelle "wahr" ist. Ist also eine Kopie von der Quelle, nur mit dem Unterscheid das da eben nur JA oder NEIN steht. So überprüfe ich mehr oder weniger die Datenqualität. Das habe ich auch soweit hinbekommen. Jetzt sollte er aber eben noch automatisch die "NEIN" entsprechend aufbereiten. Und die Lösung mit den neuen Tabellen und so wie es atilla gemacht hat ist perfekt um das Ergebnis dann entsprechend weitergeben zu können.

Vielen Dank für deine Hilfe.

Beste Grüße

[aeugeln87]

Hallo

höfliche Frage an den Frager:   Warum muss für jedes Nein eine neue Tabelle erstellt werden??
Könnte man nişcht alle "Nein" in einer Tabelle auflisten?  Den Sinn habe ich noch nicht verstanden.

mfg  Gast 123

Ist von der Übersicht her einfacher, da das Ergebnis an mehrere Personen geht. Aber ein absolutes MUSS ist es nicht. atilla hat es ja aber sehr schön gelöst.

Beste Grüße

[aeugeln87]

Und noch eine Frage. Wie kann ich ein weiteres Tabellenblatt zu denen die nicht gelöscht werden sollen hinzufügen?

[atilla]

Hallo,

Puh, da habe ich ein bisschen getrickst und habe, glaube ich eine Interessante Lösung erstellt.

Das ist der Code:

Code:

Sub tabellenAnlegen1()
 Dim sh As Shape
   Dim i As Long, j As Long, k As Long
   Dim lngZ As Long, lngS As Long, x As Long
   
   Dim strgText As String
   
   Dim aktWks As Worksheet
   Dim wks As Worksheet
   Dim tmpWks As Worksheet

   Dim arr As Variant
   Dim D1 As Object
   Dim varK
   Set D1 = CreateObject("Scripting.Dictionary")
   On Error GoTo fehler
   Application.ScreenUpdating = False
   tab_löschen                             'alle Tabllen werden bis auf die in der Prozedur "tab_löschen" angegebenen gelöscht
   strgText = "NEIN"
   Set aktWks = Worksheets("Teilnehmende-Stammdatenblatt")
   aktWks.Copy before:=aktWks
   Set tmpWks = ActiveSheet
   
   With tmpWks                       'datentabelle
       lngZ = IIf(IsEmpty(.Cells(Rows.Count, 1)), .Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
       lngS = .Cells(1, .Columns.Count).End(xlToLeft).Column
       .Range(.Cells(3, 4), .Cells(lngZ, lngS)).Name = "ati"
       .Range(.Cells(3, lngS + 1), .Cells(lngZ, lngS + 1)).Name = "ati_ati"
       [ati] = [if(iserr(search("Nein",ati)),"",column(ati))]
       .Range("ati_ati").FormulaLocal = "=wenn(ANZAHL(D3:" & .Cells(3, lngS).Address(0, 0) & ")=0;"""";1)"
       .Range("ati_ati").Value = .Range("ati_ati").Value
       .Range("ati_ati").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
       .Range("ati_ati").Clear
       .Range("ati").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
       
       x = Range("A3").CurrentRegion.Columns.Count
       lngZ = Range("A3").CurrentRegion.Rows.Count + 2
       arr = .Range(.Cells(1, 1), .Cells(lngZ, x))
       For i = 3 To UBound(arr)
         For j = 1 To Application.Count(Rows(i))
           varK = arr(i, 1)
           If InStr(D1(varK), arr(i, 2) & "#" & arr(i, 3)) = 0 Then
             D1(varK) = D1(varK) & "#" & arr(i, 2) & "#" & arr(i, 3) & "#" & arr(i, j + 3)
           Else
             D1(varK) = D1(varK) & "|" & arr(i, j + 3)
           End If
         Next j
       Next i

       For Each varK In D1.keys
         Set wks = Worksheets.Add(After:=Sheets(Sheets.Count))
         wks.Name = Split(varK, "#")(0)
         wks.Range("A1:B1").Value = .Range("B1:C1").Value
         k = 2
         strgText = Replace(D1(varK), "#", "", 1, 1)
         For j = 0 To UBound(Split(strgText, "#"))
           wks.Cells(k, 1) = Split(strgText, "#")(j)
           wks.Cells(k, 2) = Split(strgText, "#")(j + 1)
           If UBound(Split(Split(strgText, "#")(j + 2), "|")) > 0 Then
             For i = 0 To UBound(Split(Split(strgText, "#")(j + 2), "|"))
               wks.Cells(k, 3 + i) = Replace(Cells(1, Val(Split(Split(strgText, "#")(j + 2), "|")(i))).Address(0, 0), "1", "")
             Next i
           Else
             wks.Cells(k, 3) = Replace(Cells(1, Val(Split(strgText, "#")(j + 2))).Address(0, 0), "1", "")
           End If
           k = k + 1
           j = j + 2
         Next j
         wks.Range(wks.Cells(1, 3), wks.Cells(1, wks.Range("a1").CurrentRegion.Columns.Count)) = "Fund_Spalte"
       Next
   End With
   Application.DisplayAlerts = False
   Application.DisplayAlerts = True
   BlattSortierenAuf                       'Blätter sortieren
   Application.DisplayAlerts = False       'Warnmeldung ausschalten
   tmpWks.Delete                           'wenn diese Zeile aktiviert ist, wird die neu Erstellte Kopie der Datentabelle gelöscht
   Application.DisplayAlerts = True        'Warnmeldung ein
'    tmpWks.Move before:=Sheets(1)          'wenn obige Zeile aktiviert wird, muss diese und folgende deaktiviert werden
'    tmpWks.DrawingObjects.Delete           'wenn löschzeile  aktiviert wird, muss diese vorige deaktiviert werden
   aktWks.Select                           'am Ende wieder Datentabelle auswählen
fehler:
   Application.ScreenUpdating = True
   Set wks = Nothing
   D1.RemoveAll
   Set D1 = Nothing
   If Err.Number > 0 Then MsgBox Err.Number & "  " & Err.Description

End Sub

um zu sehen, was da alles Abläuft, sollte man den Code mal in Einzelschritt ansehen (Cursor innerhalb des Codes und Taste F8 drücken)

Diese Zeile:

Code:

[ati] = [if(iserr(search("Nein",ati)),"",column(ati))]

in Verbindung mit SpecialCells habe ich mir von snb abgeschaut und schalte damit den Turbo ein. (Danke snb)
Hier ist auch interessant, wie man den Bereich dynamisch eingeben kann. Wie zu sehen, geht es nur über einen definierten Namen.

Was ich nicht geschafft habe, den String "Nein" als Variable in das Konstrukt einzubauen.
Hier kann sich vielleicht snb mal äußern.

Unten die Beispielmappe, mit der erweiterten Anpassung für die letzte Frage bezgl Ausschluss mehrerer Tabellen beim Löschen:


  Tabellen anlegen Unicate-3.xlsm (Größe: 50,05 KB / Downloads: 7)

[aeugeln87]

Hallo,

Puh, da habe ich ein bisschen getrickst und habe, glaube ich eine Interessante Lösung erstellt.

Das ist der Code:

Code:

Sub tabellenAnlegen1()
 Dim sh As Shape
   Dim i As Long, j As Long, k As Long
   Dim lngZ As Long, lngS As Long, x As Long
   
   Dim strgText As String
   
   Dim aktWks As Worksheet
   Dim wks As Worksheet
   Dim tmpWks As Worksheet

   Dim arr As Variant
   Dim D1 As Object
   Dim varK
   Set D1 = CreateObject("Scripting.Dictionary")
   On Error GoTo fehler
   Application.ScreenUpdating = False
   tab_löschen                             'alle Tabllen werden bis auf die in der Prozedur "tab_löschen" angegebenen gelöscht
   strgText = "NEIN"
   Set aktWks = Worksheets("Teilnehmende-Stammdatenblatt")
   aktWks.Copy before:=aktWks
   Set tmpWks = ActiveSheet
   
   With tmpWks                       'datentabelle
       lngZ = IIf(IsEmpty(.Cells(Rows.Count, 1)), .Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
       lngS = .Cells(1, .Columns.Count).End(xlToLeft).Column
       .Range(.Cells(3, 4), .Cells(lngZ, lngS)).Name = "ati"
       .Range(.Cells(3, lngS + 1), .Cells(lngZ, lngS + 1)).Name = "ati_ati"
       [ati] = [if(iserr(search("Nein",ati)),"",column(ati))]
       .Range("ati_ati").FormulaLocal = "=wenn(ANZAHL(D3:" & .Cells(3, lngS).Address(0, 0) & ")=0;"""";1)"
       .Range("ati_ati").Value = .Range("ati_ati").Value
       .Range("ati_ati").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
       .Range("ati_ati").Clear
       .Range("ati").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
       
       x = Range("A3").CurrentRegion.Columns.Count
       lngZ = Range("A3").CurrentRegion.Rows.Count + 2
       arr = .Range(.Cells(1, 1), .Cells(lngZ, x))
       For i = 3 To UBound(arr)
         For j = 1 To Application.Count(Rows(i))
           varK = arr(i, 1)
           If InStr(D1(varK), arr(i, 2) & "#" & arr(i, 3)) = 0 Then
             D1(varK) = D1(varK) & "#" & arr(i, 2) & "#" & arr(i, 3) & "#" & arr(i, j + 3)
           Else
             D1(varK) = D1(varK) & "|" & arr(i, j + 3)
           End If
         Next j
       Next i

       For Each varK In D1.keys
         Set wks = Worksheets.Add(After:=Sheets(Sheets.Count))
         wks.Name = Split(varK, "#")(0)
         wks.Range("A1:B1").Value = .Range("B1:C1").Value
         k = 2
         strgText = Replace(D1(varK), "#", "", 1, 1)
         For j = 0 To UBound(Split(strgText, "#"))
           wks.Cells(k, 1) = Split(strgText, "#")(j)
           wks.Cells(k, 2) = Split(strgText, "#")(j + 1)
           If UBound(Split(Split(strgText, "#")(j + 2), "|")) > 0 Then
             For i = 0 To UBound(Split(Split(strgText, "#")(j + 2), "|"))
               wks.Cells(k, 3 + i) = Replace(Cells(1, Val(Split(Split(strgText, "#")(j + 2), "|")(i))).Address(0, 0), "1", "")
             Next i
           Else
             wks.Cells(k, 3) = Replace(Cells(1, Val(Split(strgText, "#")(j + 2))).Address(0, 0), "1", "")
           End If
           k = k + 1
           j = j + 2
         Next j
         wks.Range(wks.Cells(1, 3), wks.Cells(1, wks.Range("a1").CurrentRegion.Columns.Count)) = "Fund_Spalte"
       Next
   End With
   Application.DisplayAlerts = False
   Application.DisplayAlerts = True
   BlattSortierenAuf                       'Blätter sortieren
   Application.DisplayAlerts = False       'Warnmeldung ausschalten
   tmpWks.Delete                           'wenn diese Zeile aktiviert ist, wird die neu Erstellte Kopie der Datentabelle gelöscht
   Application.DisplayAlerts = True        'Warnmeldung ein
'    tmpWks.Move before:=Sheets(1)          'wenn obige Zeile aktiviert wird, muss diese und folgende deaktiviert werden
'    tmpWks.DrawingObjects.Delete           'wenn löschzeile  aktiviert wird, muss diese vorige deaktiviert werden
   aktWks.Select                           'am Ende wieder Datentabelle auswählen
fehler:
   Application.ScreenUpdating = True
   Set wks = Nothing
   D1.RemoveAll
   Set D1 = Nothing
   If Err.Number > 0 Then MsgBox Err.Number & "  " & Err.Description

End Sub

um zu sehen, was da alles Abläuft, sollte man den Code mal in Einzelschritt ansehen (Cursor innerhalb des Codes und Taste F8 drücken)

Diese Zeile:

Code:

[ati] = [if(iserr(search("Nein",ati)),"",column(ati))]

in Verbindung mit SpecialCells habe ich mir von snb abgeschaut und schalte damit den Turbo ein. (Danke snb)
Hier ist auch interessant, wie man den Bereich dynamisch eingeben kann. Wie zu sehen, geht es nur über einen definierten Namen.

Was ich nicht geschafft habe, den String "Nein" als Variable in das Konstrukt einzubauen.
Hier kann sich vielleicht snb mal äußern.

Unten die Beispielmappe, mit der erweiterten Anpassung für die letzte Frage bezgl Ausschluss mehrerer Tabellen beim Löschen:

Hallo atilla, 

ja, genau so soll es sein. Perfekt, danke dir.

Allerdings habe ich jetzt Probleme das Skript auf meine Tabelle anzupassen (Löschen geht!). Kann das Skript nicht mehr nachvollziehen^^ Vorher konnte ich folgendes selber anpassen und es ging:

- Name des Datenblatt: Kontrolle (Teilnehmende-Stammdatenblatt ist die Quelle und soll auch nicht gelöscht werden   )
- abzusuchender Bereich: B7 : B4500 - DH7 : DH4500
- Spalten A-C in Quelle, also ProjektNR Vorname Name: Steht in IB-ID

Wäre super wenn du mir da noch helfen könntest. 

Und folgende Aussage verstehe ich nicht, ist die relevant für mich oder eher Codeoptimierung? Weil es funktioniert ja wunderbar.

Was ich nicht geschafft habe, den String "Nein" als Variable in das Konstrukt einzubauen.

Beste Grüße
Michael

[atilla]

Hallo,

das ist Mist, Mist, Mist, Mist ...................

Sorry, da übe ich stundenlang Zaubertricks, die ich bei Anderen abgeschaut habe und kann sie einigermaßen hier zur Schau stellen und dann kommst Du
mit, hier sollst Du die nicht aufführen, das muss ganz wo anders passieren.  :60:

Weißt Du wie viel Arbeit das macht alles wieder einzupacken und wo anders hinzutransportieren. Dann muss ich gucken, ob am neuen Ort überhaupt die
Gegebenheiten so sind, dass ich wieder die gleichen Kunststücke aufführen kann.

Bevor ich jetzt noch einmal etwas hin-und her transportiere  :79:, musst Du mich zu dem neuen Ort mitnehmen und ich sehe mir das dann vor Ort an, was machbar ist oder nicht.

[snb]

@Att

nur für dich:

Code:

Sub M_snb()
  sn = Tabelle1.Cells(1).CurrentRegion
   
  For j = 2 To UBound(sn)
    For jj = 4 To UBound(sn, 2)
      If sn(j, jj) = "NEIN" Then Exit For
    Next
    If jj <= UBound(sn, 2) Then c00 = c00 & " " & j
  Next
   
  sp = Application.Index(sn, Application.Transpose(Split(Trim(c00))), [transpose(row(1:9))])
   
  With CreateObject("scripting.dictionary")
    For j = 1 To UBound(sp)
      .Item(sp(j, 1)) = .Item(sp(j, 1)) & " " & j
    Next
      
    For j = 0 To .Count - 1
      Sheets.Add(, Sheets(Sheets.Count)).Name = .Keys()(j)
      Sheets(Sheets.Count).Cells(1).Resize(UBound(Split(Trim(.items()(j)))) + 1, UBound(sp, 2)) = Application.Index(sp, Application.Transpose(Split(Trim(.items()(j)))), [transpose(row(1:9))])
    Next
  End With
End Sub