|
Hallo Zusammen,
im unten stehenden Code werden die Werte aus der Quelldatei in die Zieldatei nicht kopiert. Es kommt keine Fehlermeldung...
Der Code öffnet die Mappe, hebt Schreibschutz auf, und soll die Werte übernehmen, und wieder die geöffnete Datei schließen.
Das Programm macht alles, außer der Wertübernahme....Die Zeilenweise Überprüfung durcch mit F8 ging auch gut, alles O.K. wie vorgestellt in der Theorie, in der Praxis aber nicht...
Bitte um Hilfe 
Freundliche Grüße
Axl
Sub Makro1()
'Hilfsvariablen
Dim iRow As Long, j As Long, i As Long
Dim strDateipfad As String
Dim strPfad As String
Dim strDateiname As String
Dim Wb As Workbook
Dim Ws As Worksheet
Application.ScreenUpdating = False
'Pfad in welchem die Dateien der zu
'kopierenden Zellen sich befinden auswählen
strPfad = ThisWorkbook.Path & Application.PathSeparator
'Schleife welche den Zelleninhalt aller aufgelisteten
'Dateien in mehrere Zellen des Hauptprogramms schreibt
For iRow = 4 To Cells(Rows.Count, 4).End(xlUp).Row
'Überprüfen, ob in Spalte "Dateiname" ein solcher eingetragen ist.
'(der Arbeitsvorgang wird fortgesetzt)
If Cells(iRow, 2) = "" Then 'Wenn Zelle in Spalte B Leer dann Exit
Exit Sub
Else
strDateiname = Cells(iRow, 2)
strDateipfad = strPfad & strDateiname & ".xlsm"
'Überprüfen, ob die in der Tabelle angegebene Datei vorhanden ist.
'(der Arbeitsvorgang wird fortgesetzt)
If Len(Dir(strDateipfad)) Then '<==== !!!
If isFileOpen(strDateipfad) Then '<==== !!!
Cells(iRow, 3) = "nicht aktuell" ' oder anders reagieren
GoTo Nxt_File ' Überspringe das Öffnen der Arbeitsmappe
Else
Cells(iRow, 3) = "aktuell"
End If
Set Wb = Application.Workbooks.Open(Filename:=strDateipfad) '<==== !!! Quelldatei-Arbeitsmappe
For i = 1 To Sheets.Count '<==== !!! Schreibschutz aufheben in geöffn Dateien
ActiveWorkbook.Sheets(i).Unprotect Password:="KKI"
Next
Set Ws = Wb.Worksheets("Schnittstelle") '<==== !!! Arbeitsblatt in Quelldatei-Arb.Mappe
For j = 7 To 27
Cells(iRow, j) = Ws.Cells(j + 19, 2) '<==== !!! 'Cells(Durchsuchte ZEILE der Namen, Spaltenindex) =
Next j ' (iRow, 7 to 27) <== (26 to 46, 2)
Wb.Worksheets("Zusammenfassung").Select '<==== !!! "Zusammenfassung" selektieren
Wb.Close saveChanges:=False '<==== !!! Schließen der Mappe
End If
End If
Nxt_File:
Next iRow
End Sub
Sub keine_Verknuepfung()
Dim nRow As Long
For nRow = 4 To Cells(Rows.Count, 4).End(xlUp).Row
If Cells(nRow, 10).Value = "" Then
Cells(nRow, 3) = "keine Verknüpfung"
End If
Next nRow
End Sub
Function isFileOpen(sFullname As String) As Boolean
Dim kn As Integer, errNum As Long
On Error Resume Next '<===
kn = FreeFile
Open sFullname For Input Lock Read As #kn
errNum = Err.Number '<===
Close #kn
On Error GoTo 0 '<===
Select Case errNum
Case 0 ' nicht geöffnet
isFileOpen = False
' Case 70 ' bereits geöffnet
Case 55, 70 ' bereits geöffnet(55), Zugriff/Berechtigung verweigert(70)
isFileOpen = True
Case Else ' anderer Fehler
Error errNum
End Select
End Function
|