Macro pour consolider plusieurs fichiers Excel en une seule

Bonjour à tous,

Je m'adresse à vous pour m'aider pour résoudre un problématique, dans ce qui suit une macro qui a pour but de consolider des fichiers Excel qui se trouve dans le même répertoire la macro marche bien sauf que j'ai besoin de réinitialiser les cellule du fichiers destination a zéro, c'est à dire si j’exécute la macro est j'aurai 30 ligne, quand j'efface le fichier de destination et je ré_exécute la macro j'aurai les cellules copiées dans le fichiers de destination à partir de la ligne 31.

Option Explicit
Public strPath As String
Public Type SELECTINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Declare Function SHGetPathFromIDList Lib "shell32.dll" _
                                     Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
                                   Alias "SHBrowseForFolderA" (lpBrowseInfo As SELECTINFO) As Long
Function SelectFolder(Optional Msg) As String
    Dim sInfo As SELECTINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer
    sInfo.pidlRoot = 0&

    If IsMissing(Msg) Then
        sInfo.lpszTitle = "Select your folder."
    Else
        sInfo.lpszTitle = Msg
    End If

    sInfo.ulFlags = &H1

    x = SHBrowseForFolder(sInfo)

    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        SelectFolder = Left(path, pos - 1)
    Else
        SelectFolder = ""
    End If
End Function
'Merge all your excel files to a main file.
Sub MergeExcels()
    Dim path As String, ThisWB As String, lngFilecounter As Long
    Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
    Dim Filename As String, Wkb As Workbook
    Dim CopyRng As Range, Dest As Range
    Dim RowofCopySheet As Integer

    RowofCopySheet = 1 ' Row Number from where you wish to start copying

    ThisWB = ActiveWorkbook.Name

    path = SelectFolder("Select a folder containing Excel files you want to merge")

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set shtDest = ActiveWorkbook.Sheets(1)
    Filename = Dir(path & "\*.xls", vbNormal)
    If Len(Filename) = 0 Then Exit Sub
    Do Until Filename = vbNullString
        If Not Filename = ThisWB Then
            Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
            Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
            Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
            CopyRng.Copy Dest
            Wkb.Close False
        End If

        Filename = Dir()
    Loop

    Range("A1").Select

    Application.EnableEvents = True
    Application.ScreenUpdating = True

    MsgBox "Files Merged!"
End Sub
Rechercher des sujets similaires à "macro consolider fichiers seule"