|
Danke an alle und besonders an Ralf vieeeeeeelmals !!!!!!
Mit viel Rumprobieren und rumpuzzlen ist es endlich soweit! der Code funkt und ich konnte sogar eine Menge lernen!
Der Code sieht bestimmt nicht sehr proffessionel aus und könnte gebessert werden, ist aber egal, da es funktioniert :)
unten der Coder, für die, die es gebrauchen könnten :)
Freundliche Grüße
Axl
Der Code macht folgendes: Überprüft, ob in einem Verzeichnis die Datei existiert, die bei dir in der Liste steht. Datei sollte gleich heißen vor dem xls oder sxlm usw. Wenn nichts findet und der Excel keine übertragung macht, schreibt er "keine Verknüpfung". Nach der Überprüfung schaut, ob Datei von jemand geöffnet ist, schreibt "nicht aktuell" ,wenn alles gut, "aktuell" und überträgt die Daten.
Option Explicit
Sub Ubertragung()
'Neues Excel Objekt
'Dim objExcel As New Excel.Application
'Sheet Objekt der jeweiligen Exceldatei
Dim objSheet As Object
Dim shZ As Worksheet
'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, WbZ As Workbook
Set WbZ = ThisWorkbook
Set shZ = WbZ.Worksheets(1) '<=== anpassen !!!! "1" Index 1 ist die erste Arbeitstabelle
'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 'For iRow = 4 To shZ.Cells(WbZ.Rows.Count, 4).End(xlUp).Row
'Überprüfen, ob in Spalte "Dateiname" ein solcher eingetragen ist.
'(der Arbeitsvorgang wird fortgesetzt)
If shZ.Cells(iRow, 2) = "" Then '= "" Then 'Wenn Zelle in Spalte B Leer dann Exit
Exit Sub
Else
strDateiname = shZ.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
shZ.Cells(iRow, 3) = "nicht aktuell"
Else
Cells(iRow, 3) = "aktuell"
Set Wb = Workbooks.Open(strDateipfad, ReadOnly:=True)
Set objSheet = Wb.Sheets("Schnittstelle")
For I = 1 To Sheets.Count
ActiveWorkbook.Worksheets(I).Unprotect Password:="KKI" 'Schreibschutz aufheben
For j = 7 To 27
shZ.Cells(iRow, j) = objSheet.Cells(j + 19, 2)
Next j
Next I
Wb.Close saveChanges:=False
Set Wb = Nothing: Set objSheet = Nothing
End If
End If
End If
Nxt_File:
Next iRow
Set WbZ = Nothing: Set shZ = Nothing
keineVerknuepfung
End Sub
Sub keineVerknuepfung()
Dim nRow As Long
For nRow = 4 To Cells(Rows.Count, 4).End(xlUp).Row
If Cells(nRow, 15).Value = "" Then
Cells(nRow, 3) = "keine Verknüpfung"
End If
Next nRow
End Sub
Sub Abgleich()
keineVerknuepfung
Ubertragung
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
'Code Message
'----------------------------
'52 Bad file name or number
'53 File Not found
'54 Bad file mode
'55 File already open <====
'57 Device I/O error
'58 File already exists
'59 Bad record length
'61 Disk Full
'62 Input past end of file
'63 Bad record number
'67 Too many files
'68 Device unavailable
'70 Permission denied <====
'71 Disk Not Ready
'74 Can 't rename with different drive
'75 Path/File access error
'76 Path Not found
|