Automatisches Makro per Makro ändern

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Norbert,
versuch es damit:

Option Explicit
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Const MAX_PATH = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type
Private lngDirCount As Long
Private lngFileCount As Long
Private strFiles() As String
Public Sub start()
    Dim lngIndex As Long, strDateiname As String, myFSO As Object, myDrive As Object
    lngDirCount = 1
    lngFileCount = 0

'   ******************* Diesen Teil verwenden, wenn alle Mappen auf allen Laufwerke bearbeitet werden
'    Set myFSO = CreateObject("Scripting.FileSystemObject")
'    For Each myDrive In myFSO.Drives
'        If myDrive.IsReady Then Call FindFiles(myDrive.DriveLetter & ":\", "*.xls")
'    Next
'    Set myFSO = Nothing
'   **************************************************************************************************
'   ******************* Diesen Teil verwenden, wenn alle Mappen in einem Ordner bearbeitet werden
    Call FindFiles("D:\Eigene Dateien\Eigene Tabellen\", "*.xls")

'   **************************************************************************************************
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    For lngIndex = 1 To lngFileCount
        If strFiles(lngIndex) <> ThisWorkbook.FullName Then
            strDateiname = Right(strFiles(lngIndex), InStr(1, StrReverse(strFiles(lngIndex)), "\") - 1)
            Workbooks.Open strFiles(lngIndex)
            Call Teistring_tauschen(strDateiname)
            Workbooks(strDateiname).Close SaveChanges:=True
        End If
    Next
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    MsgBox "Fertig.", 64, "Info"
End Sub
Private Sub FindFiles(ByVal strFolderPath As String, ByVal strSearch As String)
    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strDirName As String
    If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
    lngSearch = FindFirstFile(strFolderPath & "*.*", WFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        GetFilesInFolder strFolderPath, strSearch
        Do
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
                strDirName = TrimNulls(WFD.cFileName)
                If (strDirName <> ".") And (strDirName <> "..") Then
                    lngDirCount = lngDirCount + 1
                    FindFiles strFolderPath & strDirName, strSearch
                End If
            End If
        Loop While FindNextFile(lngSearch, WFD)
        FindClose lngSearch
    End If
End Sub
Private Sub GetFilesInFolder(ByVal strFolderPath As String, ByVal strSearch As String)
    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strFileName As String
    If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
    lngSearch = FindFirstFile(strFolderPath & strSearch, WFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        Do
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY Then
                strFileName = TrimNulls(WFD.cFileName)
                lngFileCount = lngFileCount + 1
                ReDim Preserve strFiles(1 To lngFileCount)
                strFiles(lngFileCount) = strFolderPath & strFileName
            End If
        Loop While FindNextFile(lngSearch, WFD)
        FindClose lngSearch
    End If
End Sub
Private Function TrimNulls(ByVal strStringIn As String) As String
    If InStr(strStringIn, Chr(0)) > 0 Then strStringIn = Left$(strStringIn, InStr(strStringIn, Chr(0)) - 1)
    TrimNulls = strStringIn
End Function
Private Sub Teistring_tauschen(strDateiname As String)
    Dim objVBC As Object, lngLine As Long
    For Each objVBC In Workbooks(strDateiname).VBProject.VBComponents
        With objVBC.CodeModule
            For lngLine = 1 To .CountOfLines
                If Trim$(.Lines(lngLine, 1)) = "Const TBL_TARGET = " & Chr(34) & "Tabelle1" & Chr(34) Then
                    .DeleteLines lngLine
                    .InsertLines lngLine, "Const TBL_TARGET = " & Chr(34) & "Tabelle2" & Chr(34)
                    Exit Sub
                End If
            Next
        End With
    Next
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

Automatisches Makro per Makro ändern

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

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Automatisches Makro per Makro ändern

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread