Hilfszelle für Zeilebestimmung, welche kopiert wer

Forumthread: Hilfszelle für Zeilebestimmung, welche kopiert wer

Way

Hallo Leute,
ich habe eine Excel Tabelle (von B2 bis Q100), erste Zeile ist Titel (B1 bis Q1). Die Spalte A habe ich freigelassen, die möchte ich als Hilfszelle definieren, damit ich jene Zeile für VBA markieren kann, welche in einer anderen Excel-Datei(Email.xls) kopiert werden soll. Ich habe mir gedacht, ich schreibe in jener Zeile in der Spalte "A" ein "x" rein, die in der anderen Excel-Datei kopiert werden sollen. Die Zeilen können auch nicht untereinander liegen.
einbissel VBA-Code habe schon zusammen, leider funktioniert das mit der Festlegung durch "x" noch nicht richtig.
Vielen Dank schon mal für die Hilfe!
Kopie-Quelle "Registrierung.xlsm": https://www.herber.de/bbs/user/75878.xlsm
Einfügen-Ziel "Email.xls": https://www.herber.de/bbs/user/75877.xls

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

AW: Hilfszelle für Zeilebestimmung, welche kopiert wer

26.07.2011 10:51:46

fcs

Hallo Way,
hier mein Vorschlag für ein entsprechendes Makro. Die Select und Activates hab ich entfernt.
Gruß
Franz

Sub Makro7()
' Makro7 Makro
Dim Zeile As Long
Dim Spalte As Long
Dim Zeile_Z As Long
Const Auswahl As String = "x"
Dim Wert As String
Dim wbQuelle As Workbook, wksQuelle As Worksheet
Dim wbZiel As Workbook, wksZiel As Worksheet
Dim rngCopy As Range
Zeile = 2
Spalte = 1
ActiveWorkbook.Save
Set wbQuelle = Workbooks("Registrierung.xlsm")
Set wksQuelle = wbQuelle.Worksheets("TrackingListe")
With wksQuelle
.Activate
For Zeile = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
Wert = .Cells(Zeile, Spalte).Value
If Wert = Auswahl Then
If wbZiel Is Nothing Then
Set wbZiel = Workbooks.Open(Filename:="Email.xls")
'          Set wbZiel = Workbooks.Open(Filename:=wbQuelle.Path & "\" & "Email.xls")
Set wksZiel = wbZiel.Sheets("Fallliste")
'Titelzeile kopieren
Set rngCopy = .Range("B1:Q1")
With rngCopy
Zeile_Z = 1
.Copy Destination:=wksZiel.Cells(Zeile_Z, 1)
'            .Interior.Pattern = xlNone
End With
End If
'Spalten B bis Q der Zeile kopieren
Set rngCopy = .Range(.Cells(Zeile, 2), .Cells(Zeile, 17))
With rngCopy
Zeile_Z = Zeile_Z + 1
.Copy Destination:=wksZiel.Cells(Zeile_Z, 1)
.Interior.Pattern = xlNone
End With
Exit For 'Diese Zeile weglassen, wenn mehrere Zeilen mit "x" markiert sein können
End If
Next
If wbZiel Is Nothing Then
MsgBox "Es war(en) keine Zeil(en) mit """ & Auswahl & """ markiert"
Else
wbZiel.Close savechanges:=True
End If
End With
wbQuelle.Save
End Sub

AW: Hilfszelle für Zeilebestimmung, welche kopiert wer

26.07.2011 11:01:15

Way

Hallo Franz,
vielen lieben Dank! jetzt funktioniert alles! Problem gelöst!
Viele Grüße
Way

AW: Hilfszelle für Zeilebestimmung, welche kopiert wer

26.07.2011 11:15:04

Tino

Hallo,
ich war nicht so schnell wie Franz,
aber jetzt wo der Code schon mal fertig ist stelle ich ihn einfach hier rein.
Wenn Du Lust hast kannst Du ihn ja mal testen, evtl. noch den Pfad zur Email.xls anpassen.

Sub Kopiere_X()
Dim oWBEx As Workbook, strPath$, booIsOben As Boolean
Dim rngCopy As Range, rngTmp As Range

With ThisWorkbook.Sheets("TrackingListe")
    For Each rngTmp In .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
        If rngTmp = "x" Then
            If rngCopy Is Nothing Then
                Set rngCopy = rngTmp.Offset(0, 1).Resize(, 16)
            Else
                Set rngCopy = Union(rngCopy, rngTmp.Offset(0, 1).Resize(, 16))
            End If
        End If
    Next rngTmp
End With

If Not rngCopy Is Nothing Then
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
            'Pfad zur Email.xls 
            strPath = IIf(Right$(ThisWorkbook.Path, 1) = "\", _
                          ThisWorkbook.Path, ThisWorkbook.Path & "\")
            strPath = strPath & "Email.xls"
            
            Set oWBEx = Check_Mappe(strPath) 'prüfen ob geöffnet 
            
            If oWBEx Is Nothing Then
                Set oWBEx = Workbooks.Open(strPath)
            Else
                booIsOben = True
            End If
        
            With oWBEx
                If Not .ReadOnly Then
                    With oWBEx.Sheets("Fallliste")
                        rngCopy.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
                    End With 'oWBEx.Sheets("Fallliste") 
                    .Save
                    If Not booIsOben Then .Close False
                    MsgBox "Daten wurden kopiert und gespeichert"
                Else
                    MsgBox "Datei '" & oWBEx.Name & "' ist Schreibgeschützt", vbCritical
                    If Not booIsOben Then
                        .Close False
                    End If
                End If
            End With 'oWBEx 
        .ScreenUpdating = True
        .EnableEvents = True
    End With 'Application 
End If
End Sub

Function Check_Mappe(strFullName$) As Workbook
Dim oWB As Workbook
For Each oWB In Application.Workbooks
    If oWB.FullName = strFullName Then
        Set Check_Mappe = oWB
        Exit For
    End If
Next
End Function

Gruß Tino

Beliebteste Forumthreads (12 Monate)

Hilfszelle für Zeilebestimmung, welche kopiert wer

Forumthread: Hilfszelle für Zeilebestimmung, welche kopiert wer

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread