Tabellenblatt Name

Set oFS = CreateObject("Scripting.FileSystemObject") For Each oDatei In oFS.GetFolder(sDateiPfad).Files If InStrRev(oDatei.Name, "xlsx") Then sBlatt = "Tabelle1" oMe.Cells(iZeile, 2) = GetValue(sDateiPfad, oDatei.Name, sBlatt, Range("A2")) oMe.Cells(iZeile, 3) = GetValue(sDateiPfad, oDatei.Name, sBlatt, Range("B2")) oMe.Cells(iZeile, 4) = GetValue(sDateiPfad, oDatei.Name, sBlatt, Range("C2")) oMe.Cells(iZeile, 5) = GetValue(sDateiPfad, oDatei.Name, sBlatt, Range("E2"))

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

…ihrer Anlage durchnummeriert, Daniela.
In der selben Reihenfolge wird auch automatisch ein interner, sog CodeName gebildet, der dann unter (Name) führend im ObjektEigenschaften-Explorer des TabBlattes im VBE aufgeführt wird und manuell geändert wdn kann. Beides ist vom tatsächlichen BlattNamen (eigentl -Titel, der weiter unten ebenfalls im EigenschaftenExplorer aufgeführt wird, unabhängig und kann deshalb auch anstelle des BlattTitels benutzt wdn, denn der normale Nutzer wird bzw kann das nicht ändern. Er sollte also immer gleich sein, wenn die Mappe stets nur 1 Blatt enthält, egal wie der tatsächliche BlattName (Titel) lautet. Anderenfalls wird er lfd fortgeschrieben.
Luc :-?

Wenn ich den Punkt setzte, wird der Fehler immer noch ausgegeben.
Hier einmal mein Makro als ganzes. Eventuell habe ich da noch was übersehen.


Dim oMe As Worksheet, iZeile As Long, oDatei As Object
Dim oFS As Object, wbQuelle As Workbook, sBlatt As String
Set oMe = ThisWorkbook.ActiveSheet
Const sDateiPfad As String = "Pfad \"
iZeile = 19
Application.ScreenUpdating = False
Set oFS = CreateObject("Scripting.FileSystemObject")
For Each oDatei In oFS.GetFolder(sDateiPfad).Files
If InStrRev(oDatei.Name, "xlsx") Then
sBlatt = GetSheetNames(o.Blatt.Name)(0)
oMe.Cells(iZeile, 2) = GetValue(sDateiPfad, oDatei.Name, sBlatt, Range("A2"))
oMe.Cells(iZeile, 3) = GetValue(sDateiPfad, oDatei.Name, sBlatt, Range("B2"))
oMe.Cells(iZeile, 4) = GetValue(sDateiPfad, oDatei.Name, sBlatt, Range("C2"))
oMe.Cells(iZeile, 5) = GetValue(sDateiPfad, oDatei.Name, sBlatt, Range("E2"))
oMe.Cells(iZeile, 6) = GetValue(sDateiPfad, oDatei.Name, sBlatt, Range("F2"))
oMe.Cells(iZeile, 7) = GetValue(sDateiPfad, oDatei.Name, sBlatt, Range("G2"))
oMe.Cells(iZeile, 8) = GetValue(sDateiPfad, oDatei.Name, sBlatt, Range("H2"))
oMe.Cells(iZeile, 9) = GetValue(sDateiPfad, oDatei.Name, sBlatt, Range("I2"))
oMe.Cells(iZeile, 10) = GetValue(sDateiPfad, oDatei.Name, sBlatt, Range("J2"))
oMe.Cells(iZeile, 11) = GetValue(sDateiPfad, oDatei.Name, sBlatt, Range("K2"))
oMe.Cells(iZeile, 12) = GetValue(sDateiPfad, oDatei.Name, sBlatt, Range("L2"))
oMe.Cells(iZeile, 13) = GetValue(sDateiPfad, oDatei.Name, sBlatt, Range("M2"))
oMe.Cells(iZeile, 14) = GetValue(sDateiPfad, oDatei.Name, sBlatt, Range("N2"))
oMe.Cells(iZeile, 15) = GetValue(sDateiPfad, oDatei.Name, sBlatt, Range("O2"))
oMe.Hyperlinks.Add Anchor:=oMe.Cells(iZeile, 17), Address:=sDateiPfad _
& oDatei.Name, TextToDisplay:=oDatei.Name
iZeile = iZeile + 1
End If
Next
Set oMe = Nothing: Set wbQuelle = Nothing
End Sub
Private Function GetValue(ByVal sPath As String, ByVal sFile As String, _
ByVal sSheet As String, oTarget As Object) As Variant
On Error GoTo ErrorHandler
If Right$(sPath, 1)  "\" Then sPath = sPath & "\"
GetValue = ExecuteExcel4Macro("'" & sPath & "[" & sFile & "]" & sSheet & "'!" _
& oTarget.Range("A1").Address(, , xlR1C1))
On Error GoTo ErrorHandler
If IsError(GetValue) Then
GetValue = ExecuteExcel4Macro("'" & sPath & "[" & sFile & "]" & "Feuil1" & "'!" _
& oTarget.Range("A1").Address(, , xlR1C1))
End If
Exit Function
ErrorHandler:
GetValue = CVErr(xlErrRef)
End Function

Option Explicit Sub first_tabName() Dim varTabs As Variant, strFilename As String strFilename = "Pfad\" varTabs = GetSheetNames(strFilename) MsgBox varTabs(0) End Sub Private Function GetSheetNames(ByVal FileName As String) As Variant 'original by Bob Phillips, adapted by j.ehrensberger Dim objADO As Object, objCAT As Object, objTAB As Object Dim lngI As Long, intL As Integer, intP As Integer, intS As Integer Dim strCon As String, strTab As String Dim vntTmp() As Variant If Mid(FileName, InStrRev(FileName, ".") + 1) = "xls" Then strCon = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Extended Properties=Excel 8.0;" & _ "Data Source=" & FileName & ";" ElseIf Mid(FileName, InStrRev(FileName, ".") + 1) Like "xls?" Then strCon = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Extended Properties=""Excel 12.0;HDR=YES"";" _ & "Data Source=" & FileName & ";" Else Exit Function End If Set objADO = CreateObject("ADODB.Connection") objADO.Open strCon Set objCAT = CreateObject("ADOX.Catalog") Set objCAT.ActiveConnection = objADO For Each objTAB In objCAT.Tables strTab = objTAB.Name intL = Len(strTab) intP = 0 intS = 1 'Worksheet name with embedded spaces enclosed by single quotes If Left(strTab, 1) = "'" And Right(strTab, 1) = "'" Then intP = 1 intS = 2 End If 'Worksheet names always end in the "$" character If Mid$(strTab, intL - intP, 1) = "$" Then Redim Preserve vntTmp(lngI) vntTmp(lngI) = Mid$(strTab, intS, intL - (intS + intP)) lngI = lngI + 1 End If Next objTAB If lngI > 0 Then GetSheetNames = vntTmp objADO.Close Set objCAT = Nothing Set objADO = Nothing End Function

Beliebteste Forumthreads (12 Monate)

17 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread