Hallo Ch79
Ich hab das jetzt nicht getestet. Die Funktion DateiÖffnen ist bei mir so schon Jahre lang im Einsatz
und macht mir keine Probleme. Sie öffnet eine übergebene Datei oder übernimmt sie, wenn sie schon
geöffnet ist.
Die Sub ist wie gesagt nicht getestet, da mir die Originaldateien fehlen.
Exceldatei 2
-hat in Spalte B verbundene Zelle mit C Kalenderwochen mit der Abkürzung KW1, KW2, KW3.... -KW52
-es soll die entsprechende KW (gem. Excel 1) in der Spalte suchen und auf der nächsten freien Zeile die Daten aus L66:U66 einfügen
-kann es jeweils wen nur noch 1 freie Zeile zwischen den Kalenderwochen sind eine weitere freie Zeile einfügen
Ich nehme an:
- in Spalte B stehen die Kalenderwochen (was das Zelle mit C Kalenderwochen heißt, konnte ich mir nicht erklären)
- unterhalb der Zelle, in der z.B. KW44 steht, sind noch leere Zellen, in die dann die Daten kommen
Somit bitte mal selber testen und ggf. anpassen.
ralf_b hat schon recht. Bitte einfach die einzelnen Aufgaben lösen, wie Dateien öffnen, Werten in Spalten
suchen (Vergleich als Tabellenfunktion gibt es), Daten kopieren. Dann diese Lösungen kombinieren.
Wenn dann noch Fragen auftreten, diesen Code hier mitposten und dann können wir dir die Fehler erklären.
"Gib einem Mann einen Fisch und du ernährst ihn für einen Tag. Lehre einen Mann zu fischen und du ernährst ihn für sein Leben"
Konfuzius, Chinesischer Pilosoph
Ich versuche lieber das angeln zu lehren (das programmieren an sich), statt täglich Fische zu verteilen.
Danke fürs Verständnis
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\excel2.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"
Exit Sub
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(3), 0)
If VarType(varZeile) <> vbError Then
lngZielZeile = Val(VarType)
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
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
|