Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1792to1796
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Makro anpassen

Makro anpassen
21.11.2020 11:00:17
stef26
Guten Morgen liebe Excel Profis,
ich habe nochmal ein kleines Problem wo ich eure Unterstützung gut gebrauchen könnte.
Ich habe hier ein Makro:
Option Explicit
Const strSheetQ As String = "THT-Handbest." ' Die Tabelle wird ausgelesen
Const strSheetZ As String = "Tabelle1" ' Die Tabelle in dieser Datei
Const strCellQ1 As String = "K38" ' Die Zelle wird ausgelesen ;F38;F40
Public Sub Files_Read()
Dim stCalc As Integer
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
stCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
strDir = ThisWorkbook.Path  ' Datei im gleichen Ordner wie Auswertungsdateien
Set objDir = objFSO.GetFolder(strDir)
'dirInfo objDir, "*.xl*", True ' Mit Unterordner
dirInfo objDir, "*.xl*"
Fin:
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = stCalc
.DisplayAlerts = True
End With
Set objDir = Nothing
Set objFSO = Nothing
End Sub

Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
Optional ByVal blnTMP As Boolean = False)
Dim objWorkbook As Workbook
Dim strFormula As String
Dim strRange As String
Dim lngLastRow As Long
Dim arrCell As Variant
Dim intTMP As Integer
Dim varTMP As Variant
arrCell = Array("F38", "K38", "F40", "G42", _
"G44", "G46", "G47", "C5")
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName And varTMP.Name  _
ThisWorkbook.Name And Left(varTMP.Name, 1)  "~" Then
With ThisWorkbook.Worksheets(strSheetZ)
lngLastRow = IIf(Len(.Cells(.Rows.Count, 1)), _
.Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
For intTMP = 1 To 8
strRange = arrCell(intTMP - 1)
strRange = Range(strRange).Address(RowAbsolute:=True, _
ColumnAbsolute:=True, ReferenceStyle:=xlR1C1)
.Cells(lngLastRow, intTMP).Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheetQ & "'!" & strRange
Next intTMP
End With
End If
Next varTMP
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, blnTMP
Next varTMP
End If
Set objWorkbook = Nothing
End Sub
Dieses sucht in diversen Excellisten nach einem Ordner und soll aus dem Tabellenblatt "THT-Handbest." einige Zellen rausschreiben.
Problem ist aktuell, wenn das gesuchte Tabellenblatt in der Exceldatei nicht vorhanden ist, dann listet er alle verfügbaren Tabellenblätter auf. Dann muss man manuell entscheiden, welches Tabellenblatt es dann sein soll.
Diesen Teil hätte ich gerne aus dem Makro rausgeschmissen.
Ist das Tabellenblatt nicht vorhanden, dann einfach mit nächster Exceldatei weiter machen.
Wer kann mir zeigen welchen Teil ich da rausschmeißen muss?
Gruß
Stefan

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Makro anpassen
21.11.2020 22:29:35
stef26
Hallo Zusammen,
ich habe es mittlerweile anderweitig gelöst.
Damit das Thema nicht mehr bearbeitet werden muss.
Trotzdem Danke
Gruß
Stefan
Makro anpassen - Blattnamen in geschlossener Datei
21.11.2020 23:48:26
fcs
Hallo Stefan,
ich hab mal in meinem Fundus "gewühlt".
Ich habe eine Funktion gefunden, die die Blattnamen aus einer geschlossenen Datei auslesen kann.
Allerdings hat diese Funktion Probleme mit Punkten im Blattnamen.
Punkte werden nicht zurückgegeben bzw. durch ein # ersetzt, wenn sie am Ende eines Blattnamens stehen.
So musste ich noch etwas rumbasteln, um zu überprüfen, ob der Blattname "THT-Handbest." vorhanden ist.
Getestet habe ich mit der aktuellen Excel-Version im Microsoft Office 365.
LG
Franz
Option Explicit
Const strSheetQ As String = "THT-Handbest." ' Die Tabelle wird ausgelesen
Const strSheetZ As String = "Tabelle1" ' Die Tabelle in dieser Datei
Const strCellQ1 As String = "K38" ' Die Zelle wird ausgelesen ;F38;F40
Public Sub Files_Read()
Dim stCalc As Integer
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
stCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
strDir = ThisWorkbook.Path  ' Datei im gleichen Ordner wie Auswertungsdateien
Set objDir = objFSO.GetFolder(strDir)
'dirInfo objDir, "*.xl*", True ' Mit Unterordner
dirInfo objDir, "*.xl*"
Fin:
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = stCalc
.DisplayAlerts = True
End With
Set objDir = Nothing
Set objFSO = Nothing
End Sub
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
Optional ByVal blnTMP As Boolean = False)
Dim objWorkbook As Workbook
Dim strFormula As String
Dim strRange As String
Dim lngLastRow As Long
Dim arrCell As Variant
Dim intTMP As Integer
Dim varTMP As Variant
Dim vntSheets As Variant, vntRet As Variant
arrCell = Array("F38", "K38", "F40", "G42", _
"G44", "G46", "G47", "C5")
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName And varTMP.Name  _
ThisWorkbook.Name And Left(varTMP.Name, 1)  "~" Then
vntSheets = GetSheetNames(varTMP.Path)
vntRet = Application.Match(Replace(strSheetQ, ".", "") & _
IIf(Right(strSheetQ, 1) = ".", "#", ""), vntSheets, 0)
If IsError(vntRet) Then
'Datei überspringen
Else
With ThisWorkbook.Worksheets(strSheetZ)
lngLastRow = IIf(Len(.Cells(.Rows.Count, 1)), _
.Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
For intTMP = 1 To 8
strRange = arrCell(intTMP - 1)
strRange = Range(strRange).Address(RowAbsolute:=True, _
ColumnAbsolute:=True, ReferenceStyle:=xlR1C1)
.Cells(lngLastRow, intTMP).Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheetQ & "'!" & strRange
Next intTMP
End With
End If
End If
Next varTMP
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, blnTMP
Next varTMP
End If
Set objWorkbook = Nothing
End Sub
Private Function GetSheetNames(ByVal Filename As String) As Variant
'original by Bob Phillips, adapted by j.ehrensberger
'Funktion hat Probleme mit Punkten im Blattnamen
'Punkte innerhalb des Blattnamens werden gelöscht
'Ein Punkt am Ende wird durch ein "#" ersetzt
Dim objADO_Connection As Object, objADO_Catalog As Object, objADO_Tables As Object
Dim lngIndex As Long, intLength As Integer, intPos As Integer, intStart As Integer
Dim strConString As String, strTable As String
Dim vntTmp() As Variant
'If Dir(FileName, vbNormal) = "" Then Exit Function
On Error Resume Next
If Mid(Filename, InStrRev(Filename, ".") + 1) = "xls" Then
strConString = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Extended Properties=Excel 8.0;" & _
"Data Source=" & Filename & ";"
ElseIf Mid(Filename, InStrRev(Filename, ".") + 1) Like "xls?" Then
strConString = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Extended Properties=""Excel 12.0;" _
& "HDR=YES"";Data Source=" & Filename & ";"
Else
Exit Function
End If
Set objADO_Connection = CreateObject("ADODB.Connection")
objADO_Connection.Open strConString
Set objADO_Catalog = CreateObject("ADOX.Catalog")
Set objADO_Catalog.ActiveConnection = objADO_Connection
For Each objADO_Tables In objADO_Catalog.Tables
strTable = objADO_Tables.Name
intLength = Len(strTable)
intPos = 0
intStart = 1
'Worksheet name with embedded spaces enclosed by single quotes
If Left(strTable, 1) = "'" And Right(strTable, 1) = "'" Then
intPos = 1
intStart = 2
End If
'Worksheet names always end in the "$" character
If Mid$(strTable, intLength - intPos, 1) = "$" Then
ReDim Preserve vntTmp(lngIndex)
vntTmp(lngIndex) = Mid$(strTable, intStart, intLength - (intStart + intPos))
lngIndex = lngIndex + 1
End If
Next objADO_Tables
If lngIndex > 0 Then GetSheetNames = vntTmp
objADO_Connection.Close
On Error GoTo 0
Set objADO_Catalog = Nothing
Set objADO_Connection = Nothing
End Function

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige