Hallo ch79, ich hatte nun Zeit mal zwei Dateien zu erstellen und das Makro zu testen. Es war noch ein Fehler meinerseits drin. Ich suchte in Spalte 3, du hast aber in der excel2 die KW's in Spalte 2 stehen.
Fehler ist behoben und hier das aktuelle.
Wenn Fehler auftreten, bitte die Zeile mitteilen, die dann gelb hinterlegt ist. Hilft allen bei der Fehlersuche.
Falls es dich nicht bekannt ist:
- Ansicht / Lokalfenster zeigt unten ein Fenster an, in der alle aktuellen Variablen mit enthaltenen Werten aufgelistet werden
- Mit F8 kann das Makro Schritt für Schritt analysiert werden
Gruß
Der TestGast
--- Makro ---
Option Explicit
Sub DatenKopieren()
Dim intKW As Integer
Dim strKW As String
Dim varZeile As Variant
Dim wsQuelle As Worksheet
Set wsQuelle = ActiveSheet 'Muss ja das aktuelle Blatt sein, da mit Button gestartet
Dim strZielDatei As String
Dim strZielTabelle As String
strZielDatei = "c:\temp\Mappe2.xlsx" 'Hier bitte Anpassen oder eigene Abfrage erstellen
strZielTabelle = "Tabelle1" 'Hier bitte Anpassen oder eigene Abfrage erstellen
Dim lngZielZeile As Long
Dim wbZiel As Workbook
Dim wsZiel As Worksheet
'Zieldatei öffnen, oder wenn geöffnet übernehmen
Set wbZiel = DateiÖffnen(strDateiname:=strZielDatei, UpdateLinks:=True, ReadOnly:=False)
If wbZiel Is Nothing Then
MsgBox "Datei nicht gefunden!", vbCritical + vbOKOnly, "Datei nicht gefunden"
GoTo Aufräumen
End If
Set wsZiel = wbZiel.Worksheets(strZielTabelle)
'Kalenderwoche aus Excel1 auslesen
intKW = wsQuelle.Range("B41").Value
strKW = "KW" & intKW
'KWxx in Zieldatei suchen
varZeile = Application.Match(strKW, wsZiel.Columns(2), 0)
If VarType(varZeile) <> vbError Then
lngZielZeile = Val(varZeile)
Else
MsgBox "Kalenderwoche " & strKW & " nicht gefunden", vbCritical + vbOKOnly, "KW nicht gefunden"
GoTo Aufräumen
End If
'nächste freie Zelle suchen (in Spalte 2)
Do While wsZiel.Cells(lngZielZeile, 2) <> ""
lngZielZeile = lngZielZeile + 1
Loop
'Daten kopieren
wsQuelle.Range("L66:U66").Copy Destination:=wsZiel.Cells(lngZielZeile, 2)
Aufräumen:
'Aufräumen
Set wbZiel = Nothing
Set wsZiel = Nothing
Set wsQuelle = Nothing
End Sub
Private Function DateiÖffnen( _
ByVal strDateiname As String, _
ByVal UpdateLinks As Boolean, _
ByVal ReadOnly As Boolean) As Workbook
Dim WB As Workbook
Dim Pos As Long
Dim DateiName As String
Pos = InStrRev(strDateiname, "\", , vbTextCompare)
If Pos = 0 Then Exit Function
DateiName = Mid(strDateiname, Pos + 1)
For Each WB In Application.Workbooks
If WB.Name = DateiName Then
Set DateiÖffnen = WB
Exit Function
End If
Next WB
On Error Resume Next
Set DateiÖffnen = Workbooks.Open(strDateiname, UpdateLinks:=UpdateLinks, ReadOnly:=ReadOnly)
On Error GoTo 0
End Function
|