AW: Zellen zwischen Dateien übertragen
29.09.2006 17:20:19
fcs
Hallo schweigender Bob,
in dem Beispielmakro muss du noch die Namen von Dateien und Tabellen, sowie die Suchbegriffe anpassen. Falls ein Suchbegriff nicht gefunden wird eine Meldung angezeigt und ggf. kann abgebrochen werden.
Gruß
Franz
Sub DatenVonMonitorNachMaus()
Dim wbQuelle As Workbook, wbZiel As Workbook, wb As Workbook
Dim wksQ As Worksheet, wksZ As Worksheet
Dim Begriffe, SpalteZiel 'Daten-Arrays
Dim SpalteQ() As Integer, I As Integer
Dim ZeileQ1 As Long, ZeileZ1 As Long, ZeileQL As Long, ZeileQ As Long
'Array mit den Suchbegriffen in der Quelltabelle Zeile 8
Begriffe = Array("Modell", "Name", "Code", "Begriff4", "Begriff5", "Begriff6", "Begriff7", "Begriff8")
'Array mit den zugehörigen Spalten in der Zieltabelle
SpalteZiel = Array(1, 2, 3, 4, 5, 6, 7, 8)
'Dimension für Feld "SpalteQ" an Array Begriffe anpassen
ReDim SpalteQ(0 To UBound(Begriffe))
'Prüfen ob die Datei "Monitor.xls" und/oder "Maus.xls" schon geöffnet ist
For Each wb In Application.Workbooks
Select Case LCase(wb.Name)
Case LCase("Monitor.xls")
Set wbQuelle = Application.Workbooks("Monitor.xls")
Case LCase("Maus.xls")
Set wbZiel = Application.Workbooks("Maus.xls")
Case Else
'do nothing
End Select
Next
'Öffnen der Dateien falls noch nicht geöffnet
If wbQuelle Is Nothing Then
Set wbQuelle = Workbooks.Open(Filename:="C:\Lokale Daten\Test\Monitor.xls", ReadOnly:=True)
End If
Set wksQ = wbQuelle.Sheets("Modell")
If wbZiel Is Nothing Then
Set wbZiel = Workbooks.Open(Filename:="C:\Lokale Daten\Test\Maus.xls")
End If
Set wksZ = wbZiel.Sheets("Modell")
' Setzen von Startwerten
ZeileZ1 = 7 '1. Auszufüllende Zeile in Zieldatei
ZeileQ1 = 8 'Zeile mit Titeln in Quelldatei
ZeileQL = wksQ.Cells(wksQ.Rows.Count, 2).End(xlUp).Row 'Letzte Zeile mit Daten in Quelle, SpalteB
'Spalten der Begriffe in der Quelltabelle Zeile 8 ermitteln
For I = 0 To UBound(Begriffe)
SpalteQ(I) = SpalteQuelle(Begriffe(I), wksQ.Rows(ZeileQ1))
If SpalteQ(I) = 0 Then
If MsgBox("Begriff '" & Begriffe(I) & "' wurde in Quell-Tabelle nicht gefunden!" & vbLf & vbLf _
& "Weitermachen oder Abbrechen?", vbOKCancel + vbCritical, "Datentransfer") = vbCancel Then
Exit Sub
End If
End If
Next I
'Daten aus Quelle nach Ziel übertragen
For ZeileQ = ZeileQ1 + 1 To ZeileQL
For I = 0 To UBound(SpalteQ)
If SpalteQ(I) <> 0 Then
wksZ.Cells(ZeileZ1, SpalteZiel(I)).Value = wksQ.Cells(ZeileQ, SpalteQ(I)).Value
End If
Next I
ZeileZ1 = ZeileZ1 + 1
Next ZeileQ
End Sub
Private Function SpalteQuelle(ByVal Suchen As String, Bereich As Range) As Integer
Dim Zelle As Range
Set Zelle = Bereich.Find(What:=Suchen, LookIn:=xlValues, lookat:=xlWhole)
If Zelle Is Nothing Then
SpalteQuelle = 0
Else
SpalteQuelle = Zelle.Column
End If
End Function