Herbers Excel/VBA-Archiv

Makro anpassen

• Makro anpassen von stef26 vom 21.11.2020 11:00:17
• AW: Makro anpassen - von stef26 am 21.11.2020 22:29:35
• Makro anpassen - Blattnamen in geschlossener Datei - von fcs am 21.11.2020 23:48:26

Betrifft: Makro anpassen von: stef26
Geschrieben am: 21.11.2020 11:00:17

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

  

Betrifft: AW: Makro anpassen
von: stef26
Geschrieben am: 21.11.2020 22:29:35

Hallo Zusammen,
ich habe es mittlerweile anderweitig gelöst.

Damit das Thema nicht mehr bearbeitet werden muss.

Trotzdem Danke

Gruß
Stefan

  

Betrifft: Makro anpassen - Blattnamen in geschlossener Datei
von: fcs
Geschrieben am: 21.11.2020 23:48:26

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

Beiträge aus dem Excel-Forum zum Thema "Makro anpassen"