Registriert seit: 10.04.2014
Version(en): 2016 + 365
Hi Atilla,
(03.03.2017, 10:35)atilla schrieb: 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: 
Registriert seit: 12.03.2016
Version(en): Excel 2003
Hallo an alle Kollegen
Zitat: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 .....
Registriert seit: 12.03.2016
Version(en): Excel 2003
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
Registriert seit: 02.03.2017
Version(en): 2010
04.03.2017, 09:40
(Dieser Beitrag wurde zuletzt bearbeitet: 04.03.2017, 09:57 von aeugeln87.)
(03.03.2017, 00:28)atilla schrieb: 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
Registriert seit: 02.03.2017
Version(en): 2010
(03.03.2017, 14:58)Gast 123 schrieb: 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
Registriert seit: 02.03.2017
Version(en): 2010
Und noch eine Frage. Wie kann ich ein weiteres Tabellenblatt zu denen die nicht gelöscht werden sollen hinzufügen?
Registriert seit: 14.04.2014
Version(en): 2003, 2007
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)
Gruß Atilla
Registriert seit: 02.03.2017
Version(en): 2010
05.03.2017, 13:55
(Dieser Beitrag wurde zuletzt bearbeitet: 05.03.2017, 13:58 von aeugeln87.)
(04.03.2017, 13:28)atilla schrieb: 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.
Zitat:Was ich nicht geschafft habe, den String "Nein" als Variable in das Konstrukt einzubauen.
Beste Grüße
Michael
Registriert seit: 14.04.2014
Version(en): 2003, 2007
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.
Gruß Atilla
Registriert seit: 29.09.2015
Version(en): 2030,5
05.03.2017, 17:26
(Dieser Beitrag wurde zuletzt bearbeitet: 05.03.2017, 17:27 von 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
|
