Import data from multiple files VBA

[sofas]

Hello. Use this code to import multiple files to a new file and put the data under some of the problem that I face is when there are spaces in column A No, that's what's required.
Is there a way to correct it

Sub FusionFichiers()
Dim i As Long, iEntete As Long, bFirst As Boolean, bEntete As Boolean
Dim iLast As Long, iLastRow As Long, iLastCol As Long, bVide As Boolean, FSO As Object
Dim WkbFusion As Workbook, WkbDecoupage As Workbook, bDoublons As Boolean, sFeuille As String
Dim sDossier As String, sNomDossier As String, sDossierDecoupage As String, sPre As String, sNouveauNom As String

    QueryPerformanceCounter Dep

    Application.StatusBar = ""
    DecompteA

    sDossierDecoupage = ShParam.Range("A1")

    bVide = ShParam.CheckBoxes("chkVider").Value = 1
    bDoublons = ShParam.CheckBoxes("chkDoublons").Value = 1
    If bVide Then
        ShParam.CheckBoxes("chkDoublons").Value = 0
        bDoublons = False
    End If
    If Cpt = 0 Then
        MsgBox "Taper dans la colonne A un x ou X en vis à vis" & vbCrLf & _
               "des fichiers à Fusionner de la colonne B", vbInformation + vbOKOnly, "x ou X"
        Exit Sub
    End If

    sNomDossier = ShParam.Range("D7")
    sPre = ShParam.Range("D8")
    iEntete = ShParam.Range("D9")
    sFeuille = ShParam.Range("D10")
    bEntete = ShParam.CheckBoxes("chkEntete").Value = 1
    Cpt = 0
    If iEntete = 0 Then ShParam.CheckBoxes("chkEntete").Value = 0: bEntete = False

    sDossier = ThisWorkbook.Path & "\" & sNomDossier
    If bVide Then
        Set FSO = CreateObject("Scripting.FileSystemObject")
        If FSO.FolderExists(sDossier) Then FSO.DeleteFolder sDossier, True
        Set FSO = Nothing
    End If

    CreationDossier sDossier

    Application.ScreenUpdating = False
    bFirst = True
    iLast = ShParam.Cells(Rows.Count, "B").End(xlUp).Row

    If bFirst Then
        Set WkbFusion = Workbooks.Add
    End If

    For i = RDepart To iLast
        If UCase$(ShParam.Range("A" & i)) = "X" Then
            Set WkbDecoupage = Workbooks.Open(Filename:=sDossierDecoupage & "\" & ShParam.Range("B" & i), ReadOnly:=True)
            If FeuilleExiste(WkbDecoupage.Name, sFeuille) Then
                With WkbDecoupage.Worksheets(sFeuille)
                    If FeuilleVide(WkbDecoupage.Worksheets(sFeuille)) = False Then
                        iLastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
                        iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                        If bEntete Then
                            .Range("A1:A" & iEntete).Resize(, iLastCol).Copy _
                                    WkbFusion.Worksheets(1).Range("A1")
                            .Range(.Cells(iEntete + 1, "A"), .Cells(iLastRow, iLastCol)).Copy _
                                    WkbFusion.Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Offset(1)
                        Else
                            .Range(.Cells(iEntete + 1, "A"), .Cells(iLastRow, iLastCol)).Copy _
                                    WkbFusion.Worksheets(1).Cells(Rows.Count, "A").End(xlUp)
                        End If
                    Else
                        ShParam.Range("A" & i) = "o"
                    End If
                    WkbDecoupage.Close SaveChanges:=False
                End With
                Cpt = Cpt + 1
                Application.StatusBar = Cpt & " / " & iLast - RDepart + 1
            Else
                ShParam.Range("A" & i) = ""
                WkbDecoupage.Close SaveChanges:=False
            End If
            Set WkbDecoupage = Nothing
        End If
    Next i

    WkbFusion.Worksheets(1).Columns.AutoFit
    If bDoublons Then
        sNouveauNom = RenommerFichier(sDossier, sPre & ".xls")
    Else
        sNouveauNom = sDossier & "\" & sPre & ".xls"
    End If

    Application.DisplayAlerts = False
    If bEntete Then
        EnteteClasseurTempo iEntete, WkbFusion
    Else
        EnteteClasseurTempoNo WkbFusion
    End If

    If FeuilleVide(WkbFusion.Worksheets(1)) = False Then
        WkbFusion.SaveAs sNouveauNom
        WkbFusion.Close SaveChanges:=False
    Else
        WkbFusion.Close SaveChanges:=False
    End If
    Set WkbFusion = Nothing

    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    With ShParam
        .Activate
        .Range("B2").Select
    End With

    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
    Application.StatusBar = Application.StatusBar & " / Terminé : " & Format(((Fin - Dep) / Freq), "0.000 s")
End Sub

 

[Domenic]

I'm not sure I fully understand, and I've only taken a quick look at your code, but I see that you're determining the last row based on Column A for both your source worksheet and destination worksheet. It looks like you should probably be using Column B instead. First, add the following declaration to your code...

Dim destLastRow As Long

Then try the following code instead...

                        iLastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
                        iLastRow = .Cells(.Rows.Count, 2).End(xlUp).Row 'last row in Column B of source worksheet
                        With WkbFusion.Worksheets(1)
                            destLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row 'last row in Column B of destination worksheet
                        End With
                        If bEntete Then
                            .Range("A1:A" & iEntete).Resize(, iLastCol).Copy _
                                    WkbFusion.Worksheets(1).Range("A1")
                            .Range(.Cells(iEntete + 1, "A"), .Cells(iLastRow, iLastCol)).Copy _
                                    WkbFusion.Worksheets(1).Range("A" & destLastRow + 1)
                        Else
                            .Range(.Cells(iEntete + 1, "A"), .Cells(iLastRow, iLastCol)).Copy _
                                    WkbFusion.Worksheets(1).Range("A" & destLastRow)
                        End If

Hope this helps!

 

[sofas]

I'm not sure I fully understand, and I've only taken a quick look at your code, but I see that you're determining the last row based on Column A for both your source worksheet and destination worksheet. It looks like you should probably be using Column B instead. First, add the following declaration to your code...

Dim destLastRow As Long

Then try the following code instead...

                        iLastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
                        iLastRow = .Cells(.Rows.Count, 2).End(xlUp).Row 'last row in Column B of source worksheet
                        With WkbFusion.Worksheets(1)
                            destLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row 'last row in Column B of destination worksheet
                        End With
                        If bEntete Then
                            .Range("A1:A" & iEntete).Resize(, iLastCol).Copy _
                                    WkbFusion.Worksheets(1).Range("A1")
                            .Range(.Cells(iEntete + 1, "A"), .Cells(iLastRow, iLastCol)).Copy _
                                    WkbFusion.Worksheets(1).Range("A" & destLastRow + 1)
                        Else
                            .Range(.Cells(iEntete + 1, "A"), .Cells(iLastRow, iLastCol)).Copy _
                                    WkbFusion.Worksheets(1).Range("A" & destLastRow)
                        End If

Hope this helps!

Thanks for your interest. Please have a look at the file. with the required format

MediaFire

MediaFire is a simple to use free service that lets you put all your photos, documents, music, and video in a single place so you can access them anywhere and share them everywhere.

www.mediafire.com

 

[sofas]

One last question, if I want to make 3 or 4 blank rows between each copied sheet, what should I do?