Top-Themen

AppleEntwicklungHardwareInternetLinuxMicrosoftMultimediaNetzwerkeOff TopicSicherheitSonstige SystemeVirtualisierungWeiterbildungZusammenarbeit

Aktuelle Themen

Administrator.de FeedbackApache ServerAppleAssemblerAudioAusbildungAuslandBackupBasicBatch & ShellBenchmarksBibliotheken & ToolkitsBlogsCloud-DiensteClusterCMSCPU, RAM, MainboardsCSSC und C++DatenbankenDatenschutzDebianDigitiales FernsehenDNSDrucker und ScannerDSL, VDSLE-BooksE-BusinessE-MailEntwicklungErkennung und -AbwehrExchange ServerFestplatten, SSD, RaidFirewallFlatratesGoogle AndroidGrafikGrafikkarten & MonitoreGroupwareHardwareHosting & HousingHTMLHumor (lol)Hyper-VIconsIDE & EditorenInformationsdiensteInstallationInstant MessagingInternetInternet DomäneniOSISDN & AnaloganschlüsseiTunesJavaJavaScriptKiXtartKVMLAN, WAN, WirelessLinuxLinux DesktopLinux NetzwerkLinux ToolsLinux UserverwaltungLizenzierungMac OS XMicrosoftMicrosoft OfficeMikroTik RouterOSMonitoringMultimediaMultimedia & ZubehörNetzwerkeNetzwerkgrundlagenNetzwerkmanagementNetzwerkprotokolleNotebook & ZubehörNovell NetwareOff TopicOpenOffice, LibreOfficeOutlook & MailPapierkorbPascal und DelphiPeripheriegerätePerlPHPPythonRechtliche FragenRedHat, CentOS, FedoraRouter & RoutingSambaSAN, NAS, DASSchriftartenSchulung & TrainingSEOServerServer-HardwareSicherheitSicherheits-ToolsSicherheitsgrundlagenSolarisSonstige SystemeSoziale NetzwerkeSpeicherkartenStudentenjobs & PraktikumSuche ProjektpartnerSuseSwitche und HubsTipps & TricksTK-Netze & GeräteUbuntuUMTS, EDGE & GPRSUtilitiesVB for ApplicationsVerschlüsselung & ZertifikateVideo & StreamingViren und TrojanerVirtualisierungVisual StudioVmwareVoice over IPWebbrowserWebentwicklungWeiterbildungWindows 7Windows 8Windows 10Windows InstallationWindows MobileWindows NetzwerkWindows ServerWindows SystemdateienWindows ToolsWindows UpdateWindows UserverwaltungWindows VistaWindows XPXenserverXMLZusammenarbeit
GELÖST

Wenn Wert doppelt, dann Zeile darunter einfügen

Frage Microsoft Microsoft Office

Mitglied: Philosoph

Philosoph (Level 1) - Jetzt verbinden

10.01.2015, aktualisiert 14.01.2015, 1318 Aufrufe, 12 Kommentare, 3 Danke

Hallo alle zusammen!

Ich habe eine Exceldatei mit 5 Spalten. In Spalte A befinden sich Kundennummern, in Spalte B die Produktbezeichnung, in Spalte C die Farbinfo und in Spalte D befinden sich Größenangaben. Spalte E ist zunächst leer.

Folgendes soll passieren: Sobald das Skript eine Wiederholung der Artikelnummer in Spalte A erkennt, soll direkt darunter eine neue Zeile mit dem ersten Teil der Artikelnummer und den Inhalt aus Spalte Name einfügen.

Hier findet ihr meine Arbeitsdatei mit Beispiel wie das Ergebnis aussehen soll: http://www.herber.de/bbs/user/94905.xlsx

Wird eine Artikelnummer nur einmal gefunden, passiert nichts weiter und die Zeile bzw. Artikelnummer wird unverändert übersprungen.
Hat jemand so etwas umgesetzt und hat vielleicht ein Praxisbeispiel für mich?

Ich bin über jeden Tipp dankbar.

Wünsche allen ein erholsames Wochenende!
Der Tommy
Mitglied: aqui
10.01.2015, aktualisiert um 16:08 Uhr
Lasse bitte den Unsinn mit sinnfreien Doppelposts hier im Forum ! Das ist nicht gern gesehen und beschleunigt keineswegs die Lösung ! Mal ganz abgesehen das es eines Philosphens (denn philósophos="Freund der Weisheit“) sicher unwürdig, da unweise, ist !
http://www.administrator.de/forum/wenn-wert-doppelt-dann-zeile-darunter ...
Einen kann man immer löschen oder von der Freigabe ausnehmen...auch nachträglich noch !
Bitte warten ..
Mitglied: Philosoph
10.01.2015 um 16:19 Uhr
Danke für den Hinweis. Leider finde ich in der FAQ dazu nur folgendes:
So kannst Du Deinen Beitrag, der noch nicht beantwortet wurde, löschen:

Unter deinem Profil die Beitragsart und den Beitrag wählen.
Ganz rechts in dieser Zeile hinter dem betreffenden Beitrag erscheint ein X-Icon (ist das Icon nicht vorhanden, kannst Du den Beitrag nicht mehr löschen).
Alternativ: Auf den Beitrag (vielleicht möchtest du ihn ja vorher nochmal lesen, um dir ganz sicher zu sein) und unter dem Text auf Beitrag löschen klicken (auch mittels der rechten Navigation möglich).
durch Anklicken des Lösch-Icons (X) lässt sich der Beitrag nach einer Sicherheitsabfrage löschen.

Auch der zweite Beitrag ohne Kommentar lässt sich nicht löschen, da kein X-Icon vorhanden ist.

Über einen eintsprechenden Hinweis würde ich mich freuen.

LG
Tommy
Bitte warten ..
Mitglied: Dani
10.01.2015, aktualisiert um 16:21 Uhr
Moin,
ganz einfach: Weil ich wohl schneller war wie du. Ich habe den Beitrag in den Papierkorb gelegt und gesperrt.
Nun zurück zum Thema...


Gruß,
Dani (Moderator)
Bitte warten ..
Mitglied: colinardo
10.01.2015, aktualisiert um 20:12 Uhr
Hallo Tommy,
01.
Sub InsertRowAfterDuplicate() 
02.
    Dim ws As Worksheet, cell As Range, boolDouble As Boolean, arrSKU as Variant, arrPrevSKU as Variant 
03.
    Set ws = ActiveSheet 
04.
    boolDouble = False 
05.
    With ws 
06.
        Set cell = .Range("A2") 
07.
        While cell.Value <> "" 
08.
            arrSKU = Split(cell.Value, "-", -1, vbTextCompare) 
09.
            arrPrevSKU = Split(cell.Offset(-1, 0).Value, "-", -1, vbTextCompare) 
10.
            If arrPrevSKU(0) = arrSKU(0) Then 
11.
                boolDouble = True 
12.
            Else 
13.
                If boolDouble Then 
14.
                    cell.EntireRow.Insert 
15.
                    cell.Offset(-1, 0).Value = arrPrevSKU(0) 
16.
                    cell.Offset(-1, 1) = cell.Offset(-2, 1).Value 
17.
                    cell.Offset(-1, 4) = "color,size" 
18.
                End If 
19.
                boolDouble = False 
20.
            End If 
21.
            Set cell = cell.Offset(1, 0) 
22.
        Wend 
23.
        If boolDouble Then 
24.
            cell.EntireRow.Insert 
25.
            cell.Offset(-1, 0).Value = arrPrevSKU(0) 
26.
            cell.Offset(-1, 1) = cell.Offset(-2, 1).Value 
27.
            cell.Offset(-1, 4) = "color,size" 
28.
        End If 
29.
    End With 
30.
End Sub
Grüße Uwe
Bitte warten ..
Mitglied: Philosoph
10.01.2015 um 20:19 Uhr
Hallo Uwe,

vielen Dank für deine schnelle Hilfe!

Mein Ziel war es, auf eigener Faust die Lösung auf meine Datei herzuleiten. Leider komme ich doch nicht so einfach damit zurecht.
Ich habe hier einen Link mit meiner echten Arbeitsdatei. Es müssen einfach nur einige weitere Zeilen mit runter kopiert werden.
Hier die Datei zum Download, auch mit einem Beispiel wie das Ergebnis aussehen soll:
http://www.herber.de/bbs/user/94912.xlsx

Wenn es zu viel Arbeit bereitet, bin ich gerne auch über Paypal einen Obolus dafür zu leisten. Dein Ergebnis würde ich aber im Interesse aller anderen User hier veröffentlichen.

Best wishes
Tommy
Bitte warten ..
Mitglied: colinardo
10.01.2015, aktualisiert um 23:33 Uhr
Hab das noch extra etwas für dich verständlicher umgebaut, mit Kommentaren versehen und an dein neues Sheet angepasst:
01.
Sub InsertRowAfterDuplicate() 
02.
    Dim cell As Range, currSKU As String, prevSKU As String, insertRow As Boolean, newRow As Range 
03.
    Application.ScreenUpdating = False 
04.
    prevSKU = "" 
05.
    With ActiveSheet 
06.
        'Anfangszelle des Datenbereichs 
07.
        Set cell = .Range("A3") 
08.
        'So lange weitermachen bis Spalte A leer ist 
09.
        While cell.Value <> "" 
10.
            'sku der aktuellen Zelle 
11.
            currSKU = Split(cell.Value, "-", -1, vbTextCompare)(0) 
12.
            'Vergleiche aktuelle sku mit der vorherigen 
13.
            If currSKU = prevSKU Then 
14.
                'wenn nächste Zelle nicht leer ist 
15.
                If cell.Offset(1, 0).Value <> "" Then 
16.
                    ' Wenn die nächste Zelle unterschiedlich zur aktuellen ist ... 
17.
                    If Split(cell.Offset(1, 0).Value, "-", -1, vbTextCompare)(0) <> currSKU Then 
18.
                        insertRow = True 
19.
                    End If 
20.
                Else    'Zelle leer = letzte Zelle 
21.
                    insertRow = True 
22.
                End If 
23.
            End If 
24.
            If insertRow Then 
25.
                'ganze Zeile kopieren und darunter einfügen 
26.
                cell.EntireRow.Copy 
27.
                cell.Offset(1, 0).Insert 
28.
                ' Anpasungen in den Spalten der neuen Zeile vornehmen 
29.
                With cell.Offset(1, 0) 
30.
                    .Cells(1, 1).Value = currSKU 
31.
                    .Cells(1, 6).Value = 1 
32.
                    .Cells(1, 9).Value = "Deaktiviert" 
33.
                    .Cells(1, 10).Value = "" 
34.
                    .Cells(1, 11).Value = "" 
35.
                    .Cells(1, 18).Value = "configurable" 
36.
                    .Cells(1, 29).Value = "Einzeln nicht sichtbar" 
37.
                    .Cells(1, 53).Value = "configurable" 
38.
                    .Cells(1, 81).Value = "" 
39.
                    .Cells(1, 82).Value = "" 
40.
                    .Cells(1, 83).Value = "color,size" 
41.
                End With 
42.
                'Zeiger für nächste Zelle um zwei nach unten verschieben 
43.
                Set cell = cell.Offset(2, 0) 
44.
            Else 
45.
                'Zeiger für nächste Zelle um eins nach unten verschieben 
46.
                Set cell = cell.Offset(1, 0) 
47.
            End If 
48.
             
49.
            prevSKU = currSKU 
50.
            insertRow = False 
51.
        Wend 
52.
    End With 
53.
    Application.ScreenUpdating = True 
54.
    Application.CutCopyMode = False 
55.
    MsgBox "Fertig" 
56.
End Sub
Wenn es zu viel Arbeit bereitet, bin ich gerne auch über Paypal einen Obolus dafür zu leisten
Die Spende nehme ich hier dankend entgegen: Spenden

Grüße Uwe
Bitte warten ..
Mitglied: Philosoph
13.01.2015 um 01:15 Uhr
Hallo Uwe,

meine Spende ist raus! Nochmal vielen Dank für die super Leistung!

In der Praxis hat sich nun gezeigt, dass das Skript an zwei Stellen noch erweitert werden muss:

1. Alle einmaligen Artikelnummern müssen an das Ende der Tabelle verschoben werden.
2. Bei Artikelnummern die mehrfach vorhanden sind, wird die Zelle Price auf den Wert "0.00" gesetzt. Die letzte Zeile mit der gleichen Artikelnummer (durch das Script hinzugefügt) bleibt jedoch unverändert.

Ein Beispieldokument mit deinem Skript findest du hier, die Korrekturen habe ich farblich angepasst:
https://www.wetransfer.com/downloads/1d593ccba513f1a0ad6a5dad03e31c3d201 ...

Ich wäre dir sehr dankbar, wenn du mir das nochmal anpassen kannst.

Einen guten Start in die neue Woche!

LG
Tommy
Bitte warten ..
Mitglied: colinardo
13.01.2015, aktualisiert 14.01.2015
Hallo Tommy,
meine Spende ist raus! Nochmal vielen Dank für die super Leistung!
Ich bedanke mich herzlich
In der Praxis hat sich nun gezeigt, dass das Skript an zwei Stellen noch erweitert werden muss:
Ist das nicht immer so
Ich wäre dir sehr dankbar, wenn du mir das nochmal anpassen kannst.
guckst du hier
01.
Sub InsertRowAfterDuplicate() 
02.
    Dim cell As Range, currSKU As String, prevSKU As String, insertRow As Boolean, newRow As Range, strPrice As Variant, rngSingleRows As Range, row As Range 
03.
    Application.ScreenUpdating = False 
04.
    prevSKU = "" 
05.
    With ActiveSheet 
06.
        'Anfangszelle des Datenbereichs 
07.
        Set cell = .Range("A2") 
08.
        'So lange weitermachen bis Spalte A leer ist 
09.
        While cell.Value <> "" 
10.
            'sku der aktuellen Zelle 
11.
            currSKU = Split(cell.Value, "-", -1, vbTextCompare)(0) 
12.
            'Vergleiche aktuelle sku mit der vorherigen 
13.
            If currSKU = prevSKU Then 
14.
                'aktuellen Preis speichern 
15.
                strPrice = cell.Offset(0, 2).Value 
16.
                'Werte der Preiszellen setzen 
17.
                cell.Offset(-1, 2).Value = "0.00" 
18.
                cell.Offset(0, 2).Value = "0.00" 
19.
                 
20.
                'wenn nächste Zelle nicht leer ist 
21.
                If cell.Offset(1, 0).Value <> "" Then 
22.
                    ' Wenn die nächste Zelle unterschiedlich zur aktuellen ist ... 
23.
                    If Split(cell.Offset(1, 0).Value, "-", -1, vbTextCompare)(0) <> currSKU Then 
24.
                        insertRow = True 
25.
                    End If 
26.
                Else    'Zelle leer = letzte Zelle 
27.
                    insertRow = True 
28.
                End If 
29.
            End If 
30.
            If insertRow Then 
31.
                'ganze Zeile kopieren und darunter einfügen 
32.
                cell.EntireRow.Copy 
33.
                cell.Offset(1, 0).Insert 
34.
                ' Anpasungen in den Spalten der neuen Zeile vornehmen 
35.
                With cell.Offset(1, 0) 
36.
                    .Cells(1, 1).Value = currSKU 
37.
                    .Cells(1, 3).Value = strPrice 
38.
                    .Cells(1, 6).Value = 1 
39.
                    .Cells(1, 9).Value = "Deaktiviert" 
40.
                    .Cells(1, 10).Value = "" 
41.
                    .Cells(1, 11).Value = "" 
42.
                    .Cells(1, 18).Value = "configurable" 
43.
                    .Cells(1, 29).Value = "Einzeln nicht sichtbar" 
44.
                    .Cells(1, 53).Value = "configurable" 
45.
                    .Cells(1, 81).Value = "" 
46.
                    .Cells(1, 82).Value = "" 
47.
                    .Cells(1, 83).Value = "size,color" 
48.
                    .Cells(1, 95).Value = "" 
49.
                End With 
50.
                'Zeiger für nächste Zelle um zwei nach unten verschieben 
51.
                Set cell = cell.Offset(2, 0) 
52.
            Else 
53.
                ' Wenn die nächste Zelle unterschiedlich zur aktuellen ist, ist es eine Einzelzeile 
54.
                ' In diesem Fall speichere die Zeile zusammen mit den anderen Einzelzeilen in einer Range-Variablen 
55.
                ' um sie dann zum Schluss ans Ende zu verschieben 
56.
                If cell.Offset(1, 0).Value <> "" Then 
57.
                    If Split(cell.Offset(1, 0).Value, "-", -1, vbTextCompare)(0) <> currSKU Then 
58.
                        If Not rngSingleRows Is Nothing Then 
59.
                            Set rngSingleRows = Union(rngSingleRows, cell.EntireRow) 
60.
                        Else 
61.
                            Set rngSingleRows = cell.EntireRow 
62.
                        End If 
63.
                    End If 
64.
                End If 
65.
                'Zeiger für nächste Zelle um eins nach unten verschieben 
66.
                Set cell = cell.Offset(1, 0) 
67.
            End If 
68.
             
69.
            prevSKU = currSKU 
70.
            insertRow = False 
71.
        Wend 
72.
        'Einzelzellen am Ende einfügen 
73.
        If Not rngSingleRows Is Nothing Then 
74.
            For Each row In rngSingleRows.Rows 
75.
                row.Copy 
76.
                cell.Insert 
77.
            Next 
78.
            rngSingleRows.Delete 
79.
        End If 
80.
    End With 
81.
    Application.ScreenUpdating = True 
82.
    Application.CutCopyMode = False 
83.
    MsgBox "Fertig" 
84.
End Sub
Einen guten Start in die neue Woche!
Ebenso.

Grüße Uwe
Bitte warten ..
Mitglied: Philosoph
13.01.2015 um 23:25 Uhr
Hallo Uwe,

ich habe nun dein Script in meine Datei eingefügt und die Tabelle mit echten Artikelnummern gefüllt.
Je nach Artikelnummern, erhalte ich eine Fehlermeldung wenn ich das Script ausführe. Sheet1 und Sheet2 zeigen mir deshalb unterschiedliche Fehlermeldungen

Den Link findest zu der Datei mit beiden Sheets bzw. Fehler findest du hier: http://we.tl/UPQuEaRaOc

Hast du eine Ahnung woran das liegt oder kann mir jemand dabei weiterhelfen?


Gute Nacht!
Tommy
Bitte warten ..
Mitglied: colinardo
14.01.2015, aktualisiert um 12:11 Uhr
Zitat von Philosoph:
Hast du eine Ahnung woran das liegt oder kann mir jemand dabei weiterhelfen?
Jupp , da hatte ich eine "Kleinigkeit" nicht bedacht Ist oben im letzten Post gefixt.

Grüße Uwe
Bitte warten ..
Mitglied: Philosoph
14.01.2015 um 12:09 Uhr
Ahoi!

Hast du den Quellcode für mich?

LG
Tommy
Bitte warten ..
Mitglied: colinardo
LÖSUNG 14.01.2015, aktualisiert um 12:32 Uhr
Zitat von Philosoph:
Hast du den Quellcode für mich?
ist oben im letzten Post abgeändert... müssen hier ja nicht alles doppelt und dreifach posten .
Bitte warten ..
Neuester Wissensbeitrag
CPU, RAM, Mainboards

Angetestet: PC Engines APU 3a2 im Rack-Gehäuse

(1)

Erfahrungsbericht von ashnod zum Thema CPU, RAM, Mainboards ...

Ähnliche Inhalte
Datenbanken
Mit sql eine Zeile einfügen, select und feste Werte (9)

Frage von helmuthelmut2000 zum Thema Datenbanken ...

Batch & Shell
Text in neue 1. Zeile in Textdatei einfügen (4)

Frage von FuxxLi zum Thema Batch & Shell ...

Microsoft Office
gelöst Wie kann man die Standard-Schriftart bei einfügen von Text in Word 2013 festlegen? (3)

Frage von Rene1976 zum Thema Microsoft Office ...

Heiß diskutierte Inhalte
DSL, VDSL
DSL-Signal bewerten (13)

Frage von SarekHL zum Thema DSL, VDSL ...

Switche und Hubs
Trunk für 2xCisco Switch. Wo liegt der Fehler? (13)

Frage von JayyyH zum Thema Switche und Hubs ...

Windows Server
Mailserver auf Windows Server 2012 (9)

Frage von StefanT81 zum Thema Windows Server ...

Backup
Clients als Server missbrauchen? (9)

Frage von 1410640014 zum Thema Backup ...