Daten in eine andere Datei schreiben

Hallo Ihr Spezialisten,
ich möchte, dass ein Macro mir Zahlen, aus einer Tabelle einer offenen Datei, in eine andere Datei schreiben lassen!
Die Daten stehen in:
D:\RSC\20011\Einzel_8er.xls
Das Datenblatt heist: Tabelle 1
In den Zellen BE11:BE18 stehen die Zahlen. In den Zellen BH11:BH18 stehen die Namen.
Schreiben in:
Diese Zahlen sollen hinter die Namen in die Spalte G in:
D:\RSC\20011\Teilnehmer.xls
Das Datenblatt heist: Liste
geschrieben werden.
Das heist:
Das Macro soll in "D:\RSC\20011\Teilnehmer.xls\Liste" den Namen,
(den es aus "D:\RSC\20011\Einzel_8er.xls\Tabelle 1" hat,)
der in Spalte B steht finden, und in die Spalte G die Zahl schreiben.
Die Zahlen sind nicht fortlaufend!
Natürlich soll das Macro die Datei Teilnehmer zuerst öffnen und nach getaner Arbeit dann wieder schließen!
Ich hoffe, dass ich es gut genug beschrieben habe.
Vielene Dank schon mal
Euer Rüdiger

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo,
kannst mal diesen Code testen, dieser kommt in die Datei Einzel_8er.xls.

Option Explicit

Sub Uebertragen()
Dim oWB_EX As Workbook, varRow
Dim rngData As Range, rngRows As Range
Dim booIsOben As Boolean

'Pfad zur Datei Extern + Variable 
Call Check_Oben("D:\RSC\20011\Teilnehmer.xls", oWB_EX, booIsOben)

If oWB_EX Is Nothing Then Exit Sub

'Datenbereich 
Set rngData = ThisWorkbook.Sheets("Tabelle 1").Range("Be11:BH18")

With oWB_EX
    With .Sheets("Liste") 'Tabelle Extern 
        For Each rngRows In rngData.Rows
            'suche Namen aus BH in Spalte B 
            varRow = Application.Match(rngRows.Cells(1, 4), .Columns(2), 0)
            'Name gefunden? 
            If IsNumeric(varRow) Then
                'Wert aus BE übertragen 
                .Cells(varRow, 7) = rngRows.Cells(1, 1)
            End If
        Next
    End With
    .Save 'Datei speichern 
    'war Datei nicht offen? 
    If Not booIsOben Then
        .Close False 'schließen 
    End If
End With

End Sub

'Hilfsmakro um Datei zu suchen oder zu öffnen 
Sub Check_Oben(strFileFullName$, ByRef oWB_EX As Workbook, ByRef booIsOben As Boolean)
Dim strFileName$, oWB As Workbook

strFileName = Right$(strFileFullName, Len(strFileFullName) - InStrRev(strFileFullName, "\"))

For Each oWB In Workbooks
    If oWB.Name = strFileName Then
        Set oWB_EX = oWB
    End If
Next

If oWB_EX Is Nothing Then
    If Dir(strFileFullName) <> "" Then
        Set oWB_EX = Workbooks.Open("G:\1 Forum\Einzel_8er.xls") 'D:\RSC\20011\Einzel_8er.xls 
        If oWB_EX.ReadOnly Then
            oWB_EX.Close False
            Set oWB_EX = Nothing
        End If
    End If
Else
    booIsOben = True
End If

If Not oWB_EX Is Nothing Then _
    If oWB_EX.ReadOnly Then Set oWB_EX = Nothing

If oWB_EX Is Nothing Then
    MsgBox "Datei konnte nicht gefunden oder bearbeitet werden.", vbCritical
End If
End Sub

Gruß Tino

Sub Uebertragen() Dim oWB_EX As Workbook, varRow Dim rngData As Range, rngRows As Range Dim booIsOben As Boolean 'Pfad zur Datei Extern + Variable Call Check_Oben("D:\RSC\2011\Teilnehmer.xls", oWB_EX, booIsOben) If oWB_EX Is Nothing Then Exit Sub 'Datenbereich Set rngData = ThisWorkbook.Sheets("Tabelle 1").Range("Be11:BH18") With oWB_EX With .Sheets("Liste") 'Tabelle Extern For Each rngRows In rngData.Rows 'suche Namen aus BH in Spalte B varRow = Application.Match(rngRows.Cells(1, 4), .Columns(2), 0) 'Name gefunden? If IsNumeric(varRow) Then 'Wert aus BE übertragen .Cells(varRow, 7) = rngRows.Cells(1, 1) End If Next End With .Save 'Datei speichern 'war Datei nicht offen? If Not booIsOben Then .Close False 'schließen End If End With End Sub 'Hilfsmakro um Datei zu suchen oder zu öffnen Sub Check_Oben(strFileFullName$, ByRef oWB_EX As Workbook, ByRef booIsOben As Boolean) Dim strFileName$, oWB As Workbook strFileName = Right$(strFileFullName, Len(strFileFullName) - InStrRev(strFileFullName, "\")) For Each oWB In Workbooks If oWB.Name = strFileName Then Set oWB_EX = oWB End If Next If oWB_EX Is Nothing Then If Dir(strFileFullName) <> "" Then Set oWB_EX = Workbooks.Open(strFileFullName) If oWB_EX.ReadOnly Then oWB_EX.Close False Set oWB_EX = Nothing End If End If Else booIsOben = True End If If Not oWB_EX Is Nothing Then _ If oWB_EX.ReadOnly Then Set oWB_EX = Nothing If oWB_EX Is Nothing Then MsgBox "Datei konnte nicht gefunden oder bearbeitet werden.", vbCritical End If End Sub

Beliebteste Forumthreads (12 Monate)

Daten in eine andere Datei schreiben

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

311 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Daten in eine andere Datei schreiben

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

311 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread