Bestimmte Zellen in neue Tabellen kopieren

[atilla]

Ha snb,

der Code ist natürlich lecker, auch wennder hier keine Lösung des Problems ist.
Hast ja auch geschrieben, dass er extra für mich ist. Ich danke Dir dafür auch sehr herzlich.
Und jetzt das begrüßungs "HA" :

Beim rumprobieren habe ich mich die Ganze Zeit gefragt, warum Du bei folgenden Zeilen:

Code:

 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

eine Schleife nutzt.
Ich habe gedacht, hätte ich diese Zeilen eingestellt, hättest Du sicher eine Version ohne die Schleifen, vielleicht sogar mit einer Zeile Code , eingestellt.

uuuuund, ja ich habe selber diesen einzeiligen Code entwickelt:

Code:

 For j = 3 To UBound(sn)
   If IsNumeric(Application.Match("NEIN", Application.Index(sn, j), 0)) Then c00 = c00 & " " & j
 Next

Tataaaaaa...... :19:

snb, ich habe diese Zeile aufgrund des Studiums Deines eingestellten Codes entwickelt, deswegen sollte es Dich auch freuen.
Du siehst ich pass' auf, wenn Du was sagst, nicht immer aber immer ...........

[snb]

@Att

Meine doppelschleife läuft schneller ......

Doch:

Code:

Sub M_snb()
  sn = Tabelle1.Cells(1).CurrentRegion
  sp = Application.Index(sn, Application.Transpose(Filter([transpose(if(countif(offset(A1:I1,row(1:13),0),"NEIN")>0,row(2:14)))], "False", 0)), [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

[aeugeln87]

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.

Hallo atilla,

mist, sorry, ich habe nicht gedacht, dass die Sache so kompliziert ist. In der ersten Version hat es auch super funktioniert den Code für mich anzupassen. 

Also das Datenblatt "Teilnehmende-Stammdatenblatt" und "Kontrolle" sind identisch bis auf das im letzteren statt dem Quellwert eben nur JA oder NEIN als Ergebnis einer Formel steht. Wenn es die Sache vereinfacht, kann ich die Datenblattätter auch einfach umbenennen, ist ja vom Layout identisch. 

Vereinfacht diese Situation schon nicht vieles? Welche Infos bräuchtest du denn von mir? Könnte dir ja auch mal einen Screenshot zukommen lassen. 

Beste Grüße
Michael

[snb]

CEF ist kein software Dienstleister.

[atilla]

Hallo Michael,

ich wollte nur ein wenig Drama.
Die Infos die man braucht, sind immer die gleichen, wo genau stehen die Daten?
Nach Deinen letzten Angaben hast Du zwei getrennte Bereiche.
B-DH mit JA/NEIN
IB-ID mit Projekt und Namen

Die JA/NEIN und Projekt etc beginnen ab Zeile 7 gehen bis Zeile 4500

Das sind die Vorgaben, unter denen ich den unten eingestellten Code erarbeitet habe.

Code:

Sub tabellenAnlegen1()
   Dim i As Long, j As Long, k As Long
   
   Dim strgText As String

   Dim aktWks As Worksheet
   Dim wks As Worksheet
   Dim tmpWks As Worksheet

   Dim arr As Variant, arr2 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         'Kopie der Datentabelle wird angelegt
   Set tmpWks = ActiveSheet
   
   With tmpWks                             'Kopie der Datentabelle
       .Range("B7:DH4500").Name = "ati"    'Bereich mit JA/NEIN
       [ati] = [if(iserr(search("Nein",ati)),"",column(ati))]  'alle Ja aus dem Bereich werden entfernt und für Nein wird Spaltenzahl eingetragen
       arr = .Range("ati")
       arr2 = .Range("IB7:ID4500")       '- Spalten A-C in Quelle, also ProjektNR Vorname Name: Steht in IB-ID
       For i = 1 To UBound(arr)          'ab hier werden Unikate eingelesen und die zugehötigen Namen und Spalten drangehangangen
         For j = 1 To UBound(arr, 2)
           If arr(i, j) <> "" Then
           varK = arr2(i, 1)
             If InStr(D1(varK), arr2(i, 2) & "#" & arr2(i, 3)) = 0 Then
               D1(varK) = D1(varK) & "#" & arr2(i, 2) & "#" & arr2(i, 3) & "#" & arr(i, j)
             Else
               D1(varK) = D1(varK) & "|" & arr(i, j)
             End If
           End If
         Next j
       Next i

'ab hier werden Unikat aufgesplitet, Tabellen angelkegt
'und die Namen und Splaten werden in Zellen verteilt
       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", "")    'aus der Sapltenzahl den spaltenbuchstaben ableiten
           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                           'die  erstellte Kopie der Datentabelle wird gelöscht
   Application.DisplayAlerts = True        'Warnmeldung ein
   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

Zum Löschen der Tabellen wird noch folgender Code gebraucht:

Code:

Sub tab_löschen()
'die in Anführungszeichen stehenden Tabellen werden nicht gelöscht
Dim j As Integer
   For j = Sheets.Count To 1 Step -1
       If Sheets(j).Name <> "Teilnehmende-Stammdatenblatt" And Sheets(j).Name <> "Tablle2" Then
           Application.DisplayAlerts = False
           Sheets(j).Delete
           Application.DisplayAlerts = True
       End If
   Next j
End Sub

Und die Tabellen werden nach Erstellung mit folgendem Code sortiert:

Code:

Sub BlattSortierenAuf()
Dim i As Integer
Dim k As Integer

For i = Sheets.Count To 1 Step -1
   For k = 1 To i - 1
     If Sheets(k).Name > Sheets(k + 1).Name Then 'Absteigend ">" rumdrehem
         Sheets(k).Move After:=Sheets(k + 1)
     End If
   Next
Next
Sheets("Teilnehmende-Stammdatenblatt").Move before:=Sheets(1) 'steht somit immer an erster Stelle
End Sub

Wie Du siehst, habe ich mit der Trickserei aufgehört, und Du solltest den Code jetzt auch anpassen können.

Ich werd die nächste zeit aber noch ein wenig die Beispiele von snb genauer studieren. Mal sehen, vielleicht kann man nachträglich noch
ein Turbo einbauen. Das ist dann aber mehr eine Spielerei für mich um auch ein Gespür für die Dinge zu bekommen.

Ich denke, hier ist Ende mit Drama. :19:

@snb
CEF ist aber hilfsbereit, wenn es geht und wenn der Einzelne Lust und Laune hat.

[atilla]

Hallo Michael,

in vorigen Code ware noch etwas Schrott drin, deswegen hier eine gesäuberte Version:

Code:

Sub tabellenAnlegen1()
   Dim i As Long, j As Long, k As Long
   
   Dim strgText As String

   Dim aktWks As Worksheet
   Dim wks As Worksheet
   Dim tmpWks As Worksheet

   Dim arr As Variant, arr2 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         'Kopie der Datentabelle wird angelegt
   Set tmpWks = ActiveSheet
   
   With tmpWks                             'Kopie der Datentabelle
       arr = .Range("B7:DH4500")         'Bereich mit JA/NEIN
       arr2 = .Range("IB7:ID4500")       '- Spalten A-C in Quelle, also ProjektNR Vorname Name: Steht in IB-ID
       For i = 1 To UBound(arr)          'ab hier werden Unikate eingelesen und die zugehötigen Namen und Spalten drangehangangen
         For j = 1 To UBound(arr, 2)
           If arr(i, j) = strgText Then
           varK = arr2(i, 1)
             If InStr(D1(varK), arr2(i, 2) & "#" & arr2(i, 3)) = 0 Then
               D1(varK) = D1(varK) & "#" & arr2(i, 2) & "#" & arr2(i, 3) & "#" & j
             Else
               D1(varK) = D1(varK) & "|" & j
             End If
           End If
         Next j
       Next i

'ab hier werden Unikat aufgesplitet, Tabellen angelkegt
'und die Namen und Splaten werden in Zellen verteilt
       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", "")    'aus der Sapltenzahl den spaltenbuchstaben ableiten
           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
   BlattSortierenAuf                       'Blätter sortieren
   tmpWks.Delete                           'die  erstellte Kopie der Datentabelle wird gelöscht
   aktWks.Select                           'am Ende wieder Datentabelle auswählen
fehler:
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
   Set wks = Nothing
   Set aktWks = Nothing
   Set tmpWks = Nothing

   D1.RemoveAll
   Set D1 = Nothing
   If Err.Number > 0 Then MsgBox Err.Number & "  " & Err.Description

End Sub

Außerdem, da ich jetzt jede Zeile abarbeite brauchte ein Zauberkunststück auch nicht mehr sein, geht so auch schneller.
Das hatte ich vorher drin, weil ich damit den abzusuchenden Bereich verkleinern wollte. Im Nachhinein und bei erwarteter Datenlage ist es eher sinnlos.
Für mich steckte hier aber sehr viel Lernerfolg drin.

[snb]

@Att

Code:

Sub M_snb()
   Application.DisplayAlerts = False

   For Each it In Sheets
      If LCase(it.Name) <> "sheet1" Then c00 = c00 & "_" & it.Name
   Next
   
   If c00 <> "" Then Sheets(Split(Mid(c00, 2), "_")).Delete
End Sub

[atilla]

snb@Att

Meine doppelschleife läuft schneller ......

Doch:

Code:

Sub M_snb()
 sn = Tabelle1.Cells(1).CurrentRegion
 sp = Application.Index(sn, Application.Transpose(Filter([transpose(if(countif(offset(A1:I1,row(1:13),0),"NEIN")>0,row(2:14)))], "False", 0)), [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

Hallo snb,

dieser Vorschlag gefällt mir nicht. Das ist aber ein Bauchgefühl. Da ich gerade gut gegessen habe, ist mein Bauchgefühl besonders gut.
Was mir hier nicht so gefällt mit der zweiten Zeile, ist die Vermischung zwischen Tabellenzugriff und einem Arrayfeld.
Außerdem ist die Angabe von festen Bezügen auch nicht immer möglich. Es fehlt mir die Dynamik.

Mich hat aber bei den von Dir gezeigten Beispiel am meisten beeindruckt, wie umfangreich und absolut effektiv die Index Funktion, sowohl in der Tabelle als auch in VBA, eingesetzt werden kann. Wirklich eine herausragende Funktion, die jeder etwas genauer betrachten sollte. Mit der Funktion Vergleich() ist sie auch in VBA immer wieder effektiv einsetzbar.

Nochmals Danke für Deine Beispiele.

Ach, den Code zum Löschen habe ich mir auch notiert.

[aeugeln87]

Hallo Michael,

in vorigen Code ware noch etwas Schrott drin, deswegen hier eine gesäuberte Version:

Code:

Sub tabellenAnlegen1()
   Dim i As Long, j As Long, k As Long
   
   Dim strgText As String

   Dim aktWks As Worksheet
   Dim wks As Worksheet
   Dim tmpWks As Worksheet

   Dim arr As Variant, arr2 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         'Kopie der Datentabelle wird angelegt
   Set tmpWks = ActiveSheet
   
   With tmpWks                             'Kopie der Datentabelle
       arr = .Range("B7:DH4500")         'Bereich mit JA/NEIN
       arr2 = .Range("IB7:ID4500")       '- Spalten A-C in Quelle, also ProjektNR Vorname Name: Steht in IB-ID
       For i = 1 To UBound(arr)          'ab hier werden Unikate eingelesen und die zugehötigen Namen und Spalten drangehangangen
         For j = 1 To UBound(arr, 2)
           If arr(i, j) = strgText Then
           varK = arr2(i, 1)
             If InStr(D1(varK), arr2(i, 2) & "#" & arr2(i, 3)) = 0 Then
               D1(varK) = D1(varK) & "#" & arr2(i, 2) & "#" & arr2(i, 3) & "#" & j
             Else
               D1(varK) = D1(varK) & "|" & j
             End If
           End If
         Next j
       Next i

'ab hier werden Unikat aufgesplitet, Tabellen angelkegt
'und die Namen und Splaten werden in Zellen verteilt
       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", "")    'aus der Sapltenzahl den spaltenbuchstaben ableiten
           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
   BlattSortierenAuf                       'Blätter sortieren
   tmpWks.Delete                           'die  erstellte Kopie der Datentabelle wird gelöscht
   aktWks.Select                           'am Ende wieder Datentabelle auswählen
fehler:
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
   Set wks = Nothing
   Set aktWks = Nothing
   Set tmpWks = Nothing

   D1.RemoveAll
   Set D1 = Nothing
   If Err.Number > 0 Then MsgBox Err.Number & "  " & Err.Description

End Sub

Außerdem, da ich jetzt jede Zeile abarbeite brauchte ein Zauberkunststück auch nicht mehr sein, geht so auch schneller.
Das hatte ich vorher drin, weil ich damit den abzusuchenden Bereich verkleinern wollte. Im Nachhinein und bei erwarteter Datenlage ist es eher sinnlos.
Für mich steckte hier aber sehr viel Lernerfolg drin.

Atilla, genau so ist es perfekt! Ich danke dir vielmals. Damit spare ich verdamt viel Zeit. Tausend Dank, echt! Auch für die ausführliche Erläuterung. Freut mich, dass du im Gegenzug deine Kentnisse aufbessern konntest  :19:

Eine Sache ist mir aufgefallen. Wenn "NEIN" in Spalte D steht, dann gibt er C in der neuen Tabelle aus, usw.

Kann das an meiner Tabelle liegen?


Beste Grüße
Michael

[atilla]

Hallo Michael,

das war ein Fehler im System:

              If InStr(D1(varK), arr2(i, 2) & "#" & arr2(i, 3)) = 0 Then
                D1(varK) = D1(varK) & "#" & arr2(i, 2) & "#" & arr2(i, 3) & "#" & j + 1
              Else
                D1(varK) = D1(varK) & "|" & j + 1
              End If

Die roten Zeichen bitte an den jeweiligen Stellen ergänzen.

Jo, Danke für die Aufgabenstellung und Schulungshilfe :19: