Top-Themen

Aktuelle Themen (A bis Z)

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 In VBA ein (Order by )

Mitglied: chaos2go

chaos2go (Level 1) - Jetzt verbinden

29.09.2014 um 10:57 Uhr, 1089 Aufrufe, 2 Kommentare, 1 Danke

cheers Leute,

ich hab folgendes anliegen :

Hab ein Report als Excel Tabelle Spalten gehn von A - AM und Zeilen Ende Offen aber meist über 20k einträge

In der Ersten Zeile steht jeweils die bezeichnung der Spalte

Was soll gemacht werden ?

Es soll in Spalte L überprüft werden welches Land eingetragen ist und für jedes Land eine neue Mappe erstellt werden in dem alle zeilen Kopiert werden die , dass selbe Land in der Spalte haben sind ca 30 verschiedene Länder



danke schon mal im vorraus




gruß chaos




Mitglied: colinardo
LÖSUNG 29.09.2014, aktualisiert um 14:30 Uhr
Moin chaos2go,
Demo-Sheet: grouped_copy_to_new_sheets_250432.xlsm
Dies kopiert die Zeilen mit den gleichen Ländern in neue Registerkarten benannt nach dem Land
01.
Sub CopyUniqueToSheets() 
02.
    Dim ws As Worksheet, newWS As Worksheet, cell As Range, dic As Object, c As Range 
03.
    'Dictionary-Objekt erzeugen 
04.
    Set dic = CreateObject("Scripting.Dictionary") 
05.
    'Worksheet festlegen in dem die Daten liegen 
06.
    Set ws = Sheets(1) 
07.
    'letze Zeile ermitteln 
08.
    lastRow = ws.UsedRange.Rows.Count 
09.
     
10.
    For Each cell In ws.Range("L2:L" & lastRow) 
11.
        'Wenn das Land in der aktuellen Zelle noch nicht verarbeitet wurde 
12.
        If Not dic.Exists(cell.Value) Then 
13.
            'Land zum Dictionary hinzufügen 
14.
            dic.Add cell.Value, "" 
15.
            'neues Worksheet hinzufügen 
16.
            Set newWS = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 
17.
            'dem Worksheet den Namen des Landes geben 
18.
            newWS.Name = cell.Value 
19.
            'Überschriftenzeile übertragen 
20.
            ws.Range("A1").EntireRow.Copy newWS.Range("A1") 
21.
            'Suche in Spalte L 
22.
            With ws.Range(cell, "L" & lastRow) 
23.
                'Suche das Land in der aktuellen Zelle 
24.
                Set c = .Find(cell.Value, LookIn:=xlValues) 
25.
                If Not c Is Nothing Then 
26.
                    firstAddress = c.Address 
27.
                    Do 
28.
                        'Eintrag gefunden, kopiere die gefundene Zeile ins neue Sheet ans Ende 
29.
                        c.EntireRow.Copy newWS.UsedRange.Cells(newWS.UsedRange.Rows.Count + 1, 1) 
30.
                        'Suche den nächsten Eintrag 
31.
                        Set c = .FindNext(c) 
32.
                    Loop While Not c Is Nothing And c.Address <> firstAddress 
33.
                End If 
34.
            End With 
35.
        End If 
36.
    Next 
37.
End Sub
Falls du die Zeilen lieber in neue Excel-Arbeitsmappen kopiert haben willst, kommt diese leicht abgewandelte Prozedur zum Einsatz:
01.
Sub CopyUniqueToNewWorkbooks() 
02.
    Dim ws As Worksheet, newWS As Worksheet, cell As Range, dic As Object, c As Range, wb As Workbook, savePath As String 
03.
    'Dictionary-Objekt erzeugen 
04.
    Set dic = CreateObject("Scripting.Dictionary") 
05.
    'Pfad festlegen in dem die neuen Mappen gespeichert werden 
06.
    savePath = ActiveWorkbook.Path 
07.
    'Worksheet festlegen in dem die Daten liegen 
08.
    Set ws = Sheets(1) 
09.
    'letze Zeile ermitteln 
10.
    lastRow = ws.UsedRange.Rows.Count 
11.
     
12.
    For Each cell In ws.Range("L2:L" & lastRow) 
13.
        'Wenn das Land in der aktuellen Zelle noch nicht verarbeitet wurde 
14.
        If Not dic.Exists(cell.Value) Then 
15.
            'Land zum Dictionary hinzufügen 
16.
            dic.Add cell.Value, "" 
17.
            'neues Workbook hinzufügen 
18.
            Set wb = Workbooks.Add 
19.
            'neues Worksheet setzen 
20.
            Set newWS = wb.Worksheets(1) 
21.
            'dem Worksheet den Namen des Landes geben 
22.
            newWS.Name = cell.Value 
23.
            'Überschriftenzeile übertragen 
24.
            ws.Range("A1").EntireRow.Copy newWS.Range("A1") 
25.
            'Suche in Spalte L 
26.
            With ws.Range(cell, "L" & lastRow) 
27.
                'Suche das Land in der aktuellen Zelle 
28.
                Set c = .Find(cell.Value, LookIn:=xlValues) 
29.
                If Not c Is Nothing Then 
30.
                    firstAddress = c.Address 
31.
                    Do 
32.
                        'Eintrag gefunden, kopiere die gefundene Zeile ins neue Sheet ans Ende 
33.
                        c.EntireRow.Copy newWS.UsedRange.Cells(newWS.UsedRange.Rows.Count + 1, 1) 
34.
                        'Suche den nächsten Eintrag 
35.
                        Set c = .FindNext(c) 
36.
                    Loop While Not c Is Nothing And c.Address <> firstAddress 
37.
                End If 
38.
            End With 
39.
            'neu erstelltes Workbook im selben Verzeichnis speichern 
40.
            wb.SaveAs savePath & "\" & cell.Value 
41.
        End If 
42.
    Next 
43.
End Sub
Als alternative zu der ersten Prozedur kann auch diese hergenommen werden, wenn die Originaltabelle nach Ländern sortiert werden darf:
01.
Sub AlternativeWithOriginalTableSort() 
02.
    Dim ws As Worksheet, newWS As Worksheet, cell As Range, dic As Object, curCell As Range, activeWS As Worksheet 
03.
    'Worksheet festlegen in dem die Daten liegen 
04.
    Set ws = Sheets(1) 
05.
    Set curCell = ws.Range("L2") 
06.
    ws.UsedRange.Sort curCell, xlAscending, Header:=xlYes 
07.
    While curCell <> "" 
08.
        If curCell.Value <> curCell.Offset(-1, 0) Then 
09.
            'neues Worksheet hinzufügen 
10.
            Set activeWS = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 
11.
            'dem Worksheet den Namen des Landes geben 
12.
            activeWS.Name = curCell.Value 
13.
            'Überschriftenzeile übertragen 
14.
            ws.Range("A1").EntireRow.Copy activeWS.Range("A1") 
15.
            'Daten der aktuellen Zeile kopieren 
16.
            curCell.EntireRow.Copy activeWS.UsedRange.Cells(activeWS.UsedRange.Rows.Count + 1, 1) 
17.
        Else 
18.
            'Daten der aktuellen Zeile kopieren 
19.
            curCell.EntireRow.Copy activeWS.UsedRange.Cells(activeWS.UsedRange.Rows.Count + 1, 1) 
20.
        End If 
21.
        'nächste Zeile setzen 
22.
        Set curCell = curCell.Offset(1, 0) 
23.
    Wend 
24.
End Sub
Alle Prozeduren finden sich im Demo-Sheet.

Viel Erfolg
Grüße Uwe
Bitte warten ..
Mitglied: chaos2go
29.09.2014 um 13:22 Uhr
Hey Uwe ,


wie geil bis du den


es läuft faden grade vielen herzlichen dank



gruß chaos
Bitte warten ..
Ähnliche Inhalte
VB for Applications
VBA - Learning by Doing ?
Frage von klhk2014VB for Applications5 Kommentare

Hallo ihr Lieben! Ich bin absoluter Nichtswisser was dieses für mich komplett neue "Programm" betrifft und wollte mich bei ...

Datenbanken

MySQL "order by" erst bestimmtes Wort, dann alphabetisch

gelöst Frage von AS-N00Datenbanken9 Kommentare

Hallo, ich möchte die Ausgabe eines Listings in einem Webshop so einstellen, dass er bei der Abfrage for der ...

Datenbanken

SQL ORDER BY und Join mit 2 Tabellen

gelöst Frage von DippsDatenbanken7 Kommentare

Hallo an alle, ich versuche gerade eine Join mit 2 Tabellen auf zubauen und mir den letzten Datensatz Anzeigen ...

Windows Server

WebCache Order zu RoamingProfil hinzufügen?

Frage von ImTrainingWindows Server

Servus, Wie kann ich den WebCache Ordner bei Bsp.: 15 Profilen Automatisch zu den Servergespeicherten Profilen Hinzufügen? GPO wäre ...

Neue Wissensbeiträge
Microsoft
ARD-Doku - Das Microsoft Dilemma
Tipp von Knorkator vor 38 MinutenMicrosoft

Hallo zusammen, vor einigen Tagen lief in der ARD u.a. Reportage. Das Youtube Video dazu dürfte länger verfügbar sein. ...

Windows 10

Neue Sicherheitslücke in Windows 10 (Version 1709) durch Google öffentlich geworden

Information von kgborn vor 18 StundenWindows 10

Vor ein paar Tagen haben Googles Sicherheitsforscher vom Projekt Zero eine Sicherheitslücke im Edge-Browser publiziert. Jetzt wurde eine weitere ...

iOS
IOS 11.2.6 verfügbar
Information von sabines vor 1 TagiOS

Mit dem Update soll der Bug behoben werden, bei dem eine bestimmte Zeichenkette IOS zum Absturz gebracht hat.

Sicherheit
Sicherheitsrisiko: Die Krux mit 7-Zip
Information von kgborn vor 1 TagSicherheit8 Kommentare

Bei vielen Anwendern ist das Tool 7-Zip zum Entpacken von Archivdateien im Einsatz. Die Software ist kostenlos und steht ...

Heiß diskutierte Inhalte
Router & Routing
LANCOM VPN CLIENT einrichten
Frage von Finchen961988Router & Routing27 Kommentare

Hallo, ich habe ein Problem und hoffe ihr könnt mir helfen, wir haben einen Kunden der hat einen Speedport ...

Windows Server
AD DS findet Domäne nicht, behebbar?
Frage von schapitzWindows Server25 Kommentare

Guten Tag, ich habe bei einem Kunden ein Problem mit den AD DS. Umgebung ist folgende: Windows Server 2016 ...

LAN, WAN, Wireless
VPN Cisco ASA5505 PaloAlto PA-200
gelöst Frage von YannoschLAN, WAN, Wireless22 Kommentare

Hallo zusammen, ich würde gerne ein Site-to-Site VPN zwischen den beiden Standorten aufbauen. PaloAlto PA200 Internetanschluss Deutsche Telekom GK ...

SAN, NAS, DAS
Qnap TS-453S Pro - Anbindung Active Directory
Frage von JuckieSAN, NAS, DAS13 Kommentare

Hallo zusammen, ich habe hier eine Qnap TS-453S Pro die sich mal so absolut gar nicht in das Active ...