MS-Office-Forum

Zurück   MS-Office-Forum > Microsoft Office > Microsoft Excel
Registrieren Forum Hilfe Alle Foren als gelesen markieren

Banner und Co.

Antworten
Ads
Themen-Optionen Ansicht
Alt 19.04.2018, 16:18   #1
Lemk
Neuer Benutzer
Neuer Benutzer
Standard VBA - Spalte A durchlaufen und wenn NICHT Leer, sichtbaren Bereich in Extrablatt kopieren

Hallo zusammen,

nach tollen Hilfestellungen durch Forenmitglieder (Danke!) hoffe ich auf einen weiteren Hinweis zum Abschluss der Tabelle.

Ich habe eine Excel-Tabelle bei der im Tabellenblatt "BEARBEITUNG" alle Bewerber- und Kennungsdaten eingetragen werden. Nach der Eintragung erfolgt die Übertragung der Bewerberdaten mittels Spezialfilter in ein neues Tabellenblatt "Anhörung".

Im Tabellenblatt "Anhörung" ist in Spalte A ein "x" gesetzt , wenn der Datensatz in einem anderen Programm bearbeitet wurde. Nach Spalte A folgen alle Bewerberdaten, wobei die zu kopierenden nicht ausgeblendet sind. Ich möchte nun VBA sagen, dass er Spalte A durchlaufen soll und solange kein "X" gesetzt und in der Nachbarspalte Inhalte sind, alle sichtbaren Inhalte von B:AL in eine neue Excel-Datei kopiert.

Zweck ist, dass meherer Leute parallel arbeiten können.

Mein aktueller Code ist sehr manuell und kopiert alles, was dann in der Serienbrieffunktion von Word sehr unübersichtlich wird:

PHP-Code:

Sub Anhörungserstellung()

    
'es wird eine neue Datei erstellt
    Workbooks.Add
    
        '
1 in () anpassenwenn nicht das 1. Tabellenblatt die Quelle ist
        With ThisWorkbook
.Sheets("Vertrag_Anhörung")
            
'Bereich E2:F75 wird kopiert
            .Range("A4:B500").Copy
                With Range("A1")
                    '
nur die Werte werden in die neue Datei an gleicher Stelle übertragen
                    
.PasteSpecial Paste:=xlPasteValuesOperation:=xlNoneSkipBlanks _
                       
:=FalseTranspose:=False
                    
'nur die Formate werden in die neue Datei an gleicher Stelle übertragen
                    .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                       SkipBlanks:=False, Transpose:=False
                End With
            .Range("E4:I500").Copy
                With Range("C1")
                    '
nur die Werte werden in die neue Datei an gleicher Stelle übertragen
                    
.PasteSpecial Paste:=xlPasteValuesOperation:=xlNoneSkipBlanks _
                       
:=FalseTranspose:=False
                    
'nur die Formate werden in die neue Datei an gleicher Stelle übertragen
                    .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                       SkipBlanks:=False, Transpose:=False
                End With
            .Range("K4:K500").Copy
                With Range("H1")
                    '
nur die Werte werden in die neue Datei an gleicher Stelle übertragen
                    
.PasteSpecial Paste:=xlPasteValuesOperation:=xlNoneSkipBlanks _
                       
:=FalseTranspose:=False
                    
'nur die Formate werden in die neue Datei an gleicher Stelle übertragen
                    .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                       SkipBlanks:=False, Transpose:=False
                End With
            .Range("O4:O500").Copy
                With Range("I1")
                    '
nur die Werte werden in die neue Datei an gleicher Stelle übertragen
                    
.PasteSpecial Paste:=xlPasteValuesOperation:=xlNoneSkipBlanks _
                       
:=FalseTranspose:=False
                    
'nur die Formate werden in die neue Datei an gleicher Stelle übertragen
                    .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                       SkipBlanks:=False, Transpose:=False
                End With
            .Range("T4:T500").Copy
                With Range("J1")
                    '
nur die Werte werden in die neue Datei an gleicher Stelle übertragen
                    
.PasteSpecial Paste:=xlPasteValuesOperation:=xlNoneSkipBlanks _
                       
:=FalseTranspose:=False
                    
'nur die Formate werden in die neue Datei an gleicher Stelle übertragen
                    .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                       SkipBlanks:=False, Transpose:=False
                End With
            .Range("W4:AF500").Copy
                With Range("K1")
                    '
nur die Werte werden in die neue Datei an gleicher Stelle übertragen
                    
.PasteSpecial Paste:=xlPasteValuesOperation:=xlNoneSkipBlanks _
                       
:=FalseTranspose:=False
                    
'nur die Formate werden in die neue Datei an gleicher Stelle übertragen
                    .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                       SkipBlanks:=False, Transpose:=False
                End With
            .Range("AK4:AL500").Copy
                With Range("U1")
                    '
nur die Werte werden in die neue Datei an gleicher Stelle übertragen
                    
.PasteSpecial Paste:=xlPasteValuesOperation:=xlNoneSkipBlanks _
                       
:=FalseTranspose:=False
                    
'nur die Formate werden in die neue Datei an gleicher Stelle übertragen
                    .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                       SkipBlanks:=False, Transpose:=False
                End With
            Application.CutCopyMode = False
            '
Blatt der neuen Tabelle erhält selben Blattnamen aus Quelldatei
            ActiveSheet
.Name "Serienbriefdaten"
            'neue Datei wird im selben Verz der Quelldatei mit dem Namen aus B2 aus Quelldatei _gespeichert
            '
existiert die Datei schonerfolgt eine Fehlermeldung
            ActiveWorkbook
.SaveAs "Anhörungserstellung. " Format(Date"yyyy-mm-dd") & ".xls"
        
End With
    
End Sub 
Meine Beispieldatei ist leider zu groß.

Wie müsste hier der Code aussehen? Über Hilfe wäre ich sehr dankbar.

VG Christoph
Lemk ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 19.04.2018, 19:15   #2
rastrans
MOF Koryphäe
MOF Koryphäe
Standard

Es ist nicht ganz klar, was du willst, aber vielleicht kannst du dir das hiermit zusammen schreiben.
Code:

Sub Anhörungserstellung()
    Const c_UeberschriftenZeile = 1
    Dim lngZeileS As Long, lngZeileD As Long
    Dim lngSpalteS As Long, lngSpalteD As Long
    Dim wsQuelle As Worksheet, wsZiel As Worksheet
    Dim rng As Range
    Dim bolNeueZeile As Boolean
    
    'Arbeitsblatt der Quelle der Daten
    Set wsQuelle = Worksheets("Anhörung")
    'Arbeitsblatt des Ziel
    Set wsZiel = Worksheets.Add(After:=wsQuelle)
    'Zeile vor der Zeile, in der der erste Datensatz geschrieben werden soll
    lngZeileD = c_UeberschriftenZeile
    'Alle Datensätze nach der Überschriftszeile durchlaufen
    For lngZeileS = c_UeberschriftenZeile + 1 To wsQuelle.Cells.SpecialCells(xlCellTypeLastCell).Row
        'Wenn in der Zeile die erste Spalte leer ist...
        If IsEmpty(wsQuelle.Cells(lngZeileS, 1)) Then
            '... dann ist es eine neue Zeile in dem Ziel
            bolNeueZeile = True
            'Alle Spalten in der Quelle durchlaufen
            For lngSpalteS = 2 To wsQuelle.Cells.SpecialCells(xlCellTypeLastCell).Column
                'Wenn die Spalte nicht versteckt ist..
                If Not wsQuelle.Columns(lngSpalteS).Hidden Then
                    'suche die gleich Überschrift, wie in der Quelle
                    Set rng = wsZiel.Rows(c_UeberschriftenZeile).Find(what:=wsQuelle.Cells(c_UeberschriftenZeile, lngSpalteS).Value, LookAt:=xlWhole)
                    'Wenn keine entsprechende Überschrift gefunden wurde
                    If rng Is Nothing Then
                        '..dann erstelle diese in der Überschriftszeile
                        lngSpalteD = wsZiel.Cells(c_UeberschriftenZeile, Columns.Count).End(xlToLeft).Column
                        If Not IsEmpty(wsZiel.Cells(c_UeberschriftenZeile, lngSpalteD)) Then lngSpalteD = lngSpalteD + 1
                        wsZiel.Cells(c_UeberschriftenZeile, lngSpalteD).Value = wsQuelle.Cells(c_UeberschriftenZeile, lngSpalteS).Value
                    Else
                        'oder merke die Spalte.
                        lngSpalteD = rng.Column
                    End If
                    'Wenn es eine neue Zeile ist
                    If bolNeueZeile Then
                        'Eine zeile tiefer
                        lngZeileD = lngZeileD + 1
                        'nun keine weitere neue Zeile gennerieren
                        bolNeueZeile = False
                    End If
                    'Wert von der Quelle ins Zile kopieren
                    wsZiel.Cells(lngZeileD, lngSpalteD).Value = wsQuelle.Cells(lngZeileS, lngSpalteS).Value
                End If
            Next
        End If
    Next
End Sub
Eine Beispieldatei kann nichts zu groß werden. Es soll ein Beispiel sein. Es reichen 10 Datensätze! Und überflüssiger Code, der nicht zu dem Problem gehört, kann gelöscht werden!

__________________

There are 10 different types of people in the world. Those who understand the binary system and those who not.

Da für die Helfer der einzige Lohn eine Rückmeldung ist, wäre ein kurzes Feedback wünschenswert.
Auch sehen andere User, die ein ähnliches Problem haben, inwiefern die Lösung zur Beseitigung des Problems beigetragen hat.
Übrigens : Hilfreiche und positive Beiträge kann man auch bewerten!
rastrans ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 20.04.2018, 06:10   #3
MisterBurns
MOF Koryphäe
MOF Koryphäe
Standard

Und zippen ist auch eine Möglichkeit...

__________________

Schöne Grüße
Berni
MisterBurns ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 23.04.2018, 16:19   #4
Lemk
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard

Zip! Guter Hinweis. War mir nicht bewusst, dass das akzeptiert wird. Das hat nun geklappt.

Der Code soll alle eingeblendeten Spalten in ein neue Excel-Datei kopieren, wenn noch kein Vertrag erstellt wurde. Wäre genial, wenn das funktionieren würde.
Angehängte Dateien
Dateityp: zip Eintrittsliste Recruiting_Light_Teil1. 2018-04-18.zip (137,8 KB, 0x aufgerufen)
Lemk ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Ads
Antworten


Aktive Benutzer in diesem Thema: 1 (Registrierte Benutzer: 0, Besucher: 1)
 
Themen-Optionen
Ansicht

Forumregeln
Es ist Ihnen nicht erlaubt, neue Themen zu verfassen.
Es ist Ihnen nicht erlaubt, auf Beiträge zu antworten.
Es ist Ihnen nicht erlaubt, Anhänge anzufügen.
Es ist Ihnen nicht erlaubt, Ihre Beiträge zu bearbeiten.

vB Code ist An.
Smileys sind An.
[IMG] Code ist An.
HTML-Code ist An.
Gehe zu


Alle Zeitangaben in WEZ +1. Es ist jetzt 01:54 Uhr.


Partner und Co.
Access-Paradies -Alles rund um die Datenbank Microsoft Access -Code -Programme-Tools -Tipps   Kostenlose Tipps & Tricks, Downloads und Programme   www.kulpa-online.com - Tipps - Tricks - Tutorials - Meinungen - Downloads uvm...   vb@rchiv · Willkommen in der Welt der VB Programmierung   Access-Garhammer - Hier finden Sie jede Menge Beispiel-Datenbanken zu Access und mehr ...   mcseboard.de   Die Top Seite für Excel-VBA-Makros uvm.

Powered by: vBulletin Version 3.6.2 (Deutsch)
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.

Copyright ©2000-2018 MS-Office-Forum. Alle Rechte vorbehalten.
Copyright ©Design: Manuela Kulpa ©Rechte: Günter Kramer
Eine Verwendung der Inhalte in anderen Publikationen, auch auszugsweise,
ist ohne ausdrückliche Zustimmung der Autoren nicht gestattet.