Zellen übertragen
Rudi
Ich möchte, dass ein Macro folgendes macht:
Es soll von der Datei "C:\RSC 2011\Doppel_5er_4_Gruppen.xls" Zellen auslesen, die Datei "C:/RSC 2011/Teilnehmer.xls" öffen und die gelesenen Daten reinschreiben und die Datei "C:/RSC 2011/Teilnehmer.xls"wieder schließen.
Die Daten sind z. B. in der genannten Datei und sollen in die folgende Datei geschrieben:
Die der Spalte ID_Nr = steht in BG30:BG32, der dazugehörige Platz steht in der Spalte BC30:BC32.
Jetzt soll das Macro die Datei "C:/RSC 2011/Teilnehmer.xls" öffnenen, die ID_Nr suchen, die in der Spalte A steht und soll den Platz in die Zeile der gefundenen ID_Nr, in die Spalte L schreiben und die DAtei "C:/RSC 2011/Teilnehmer.xls"wieder schließen.
Das war eigentlich schon alles, nur noch etwas, bitte schreibe mir in das Macro, hinter den jeweiligen Befehl, der die jeweiligen Daten aus der Datei "C:\RSC 2011\Doppel_5er_4_Gruppen.xls" ausliest, wie ich dies ändern kann, da es noch 19 andere Dateien gibt, wo die Daten in anderen Zellen sind aber immer in die Datei "C:\RSC 2011\Teilnehmer.xls" in die selben Spalten geschrieben werden sollen!
Vielen lieben Dank und noch ein schönes Wochenende wünscht Rüdiger
PS:
Ich habe schon einmal eine etwas ander Anfrage dahingehend gestellt und das folgende Macro erhalten.
Vielleicht muß man da nur etwas ändern.
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("Endspiel").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 gefundenC
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