VBA Excel03 - Création/Extraction classeur

'......
'On remet la propriété de l'application à 3 (par défaut)
xlApp.SheetsInNewWorkbook = 3
'sauvegarde fichier
xlBook.Close SaveChanges:=True

Set xlBook = Nothing

Set xlBook = Workbooks.Open("M:\Léo\Données_Gironde.xls")
Set xlSheet = xlBook.Worksheets("Population")

xlSheet.Activate

Workbooks.Open Filename:="M:\Léo\Données_Population\BTX_IC_POP_2006.xls"

Workbooks.Open Filename:="M:\Léo\Données_Population\BTX_IC_POP_2006.xls"      
xlSheet.Activate 

xlSheet

BTX_IC ...

'...... 
'On remet la propriété de l'application à 3 (par défaut) 
xlApp.SheetsInNewWorkbook = 3 
'sauvegarde fichier 
xlBook.Close SaveChanges:=True 

Set xlBook = Nothing 

Set xlBook = Workbooks.Open("M:\Léo\Données_Gironde.xls") 
Set xlSheet = xlBook.Worksheets("Population") 

Dim xlBook2 As Workbook 
Dim xlSheet2 As Worksheet  

Set xlBook2 = Workbooks.open("M:\Léo\Données_Population\BTX_IC_POP_2006.xls") 

Set xlSheet2 = xlBook2.Worksheets("Feuil2") 

Sub CreationDonneesCUB() 

Dim NbrLig, lig, NumLig As Long 
NbrLig = 65536 
Dim feuille As Worksheet 
Dim i As Integer 
i = 1 

Workbooks.Open Filename:="M:\Léo\Données_Gironde.xls" 

Workbooks("Données_Gironde.xls").Sheets(i).Activate 

NumLig = 2 

With Workbooks("Données_Gironde.xls").Sheets(i) 

For Each feuille In Worksheets 
Workbooks("Données_Gironde.xls").Sheets(i).Select 
Set feuille = Sheets.Add(After:=Sheets(Sheets.Count)) 
    For lig = 3 To NbrLig 
    com = .Cells(lig, 2).Value 
        Select Case com 
            Case "Ambarès-et-Lagrave", "Ambès", "Artigues-près-Bordeaux", "Bassens", "Bègles", "Blanquefort", "Bordeaux", "Bouliac", "Bruges", "Carbon-Blanc", "Cenon", "Eysines", "Floirac", "Gradignan", "Le Bouscat", "Le Haillan", "Le Taillan-Médoc", "Lormont", "Mérignac", "Parempuyre", "Pessac", "Saint-Aubin-de-Médoc", "Saint-Louis-de-Montferrand", "Saint-Médard-en-Jalles", "Saint-Vincent-de-Paul", "Talence", "Villenave-d'Ornon" 
                .Cells(lig, 1).EntireRow.Copy 
                NumLig = NumLig + 1 
                Cells(NumLig, 1).Select 
                ActiveSheet.Paste 
        End Select 
    Next 
NumLig = 2 
i = i + 1 
Next 
End With 


End Sub

Option Explicit  

Sub ExtractionDonneesCUB2()  

Dim com As String  
Dim NbrLig, lig, NumLig As Long  
Dim feuille As Worksheet  
Dim I As Integer  
Dim xlApp As Excel.Application  
Dim xlBook As Excel.Workbook  
Dim xlSheet As Excel.Worksheet  


    'On crée l'objet Excel  
    Set xlApp = CreateObject("Excel.Application")  
    'On défini le nombre d'onglets (ici 5)  
    xlApp.SheetsInNewWorkbook = 5  
    'On ajoute un classeur  
    Set xlBook = xlApp.Workbooks.Add  
    'On donne un nom au classeur  
    xlBook.SaveAs ("M:\Léo\Données_CUB2.xls")  
    'On rend le classeur visible  
    xlApp.Visible = True  
    'On créer l'objet onglet dans le nouveau classeur créé  
    Set xlSheet = xlBook.Worksheets(1)  
    'On affecte un nom aux l'onglets  
    xlSheet.Name = "Population"  
    'on libère l'objet onglet pour pouvoir en créer un nouveau ... etc  
    Set xlSheet = Nothing  
    '  
    '  
    Set xlSheet = xlBook.Worksheets(2)  
    xlSheet.Name = "Activité"  
    Set xlSheet = Nothing  
    '  
    '  
    Set xlSheet = xlBook.Worksheets(3)  
    xlSheet.Name = "Famille"  
    Set xlSheet = Nothing  
    '  
    '  
    Set xlSheet = xlBook.Worksheets(4)  
    xlSheet.Name = "Formation"  
    Set xlSheet = Nothing  
    '  
    '  
    Set xlSheet = xlBook.Worksheets(5)  
    xlSheet.Name = "Logement"  
    Set xlSheet = Nothing  
    '  
    '  
    'On remet la propriété de l'application à 3 (par défaut)  
    xlApp.SheetsInNewWorkbook = 3  
    'On sauvegarde le fichier  
    xlBook.Close SaveChanges:=True  
    'On libère l'objet classeur  
    Set xlBook = Nothing  

'on ouvre, dans l'ordre, fichier source, fichier recevant l'extraction  
Workbooks.Open Filename:="M:\Léo\Données_Gironde.xls"  
Workbooks.Open Filename:="M:\Léo\Données_CUB2.xls"  


Set xlBook = Workbooks("Données_Gironde")  

NumLig = 1  

For I = 1 To 5  'boucle pour opérer sur chaque feuille  

    With xlBook.Sheets(I)   'classeur et feuille source  
    NbrLig = .Cells(65536, 1).End(xlUp).Row  
      
    Workbooks("Données_Gironde.xls").Sheets(I).Range("A1:DZ1").Copy _  
    Destination:=Workbooks("Données_Gironde.xls").Sheets(I).Range("A1")  

    Workbooks("Données_CUB2.xls").Sheets(I).Select  'feuille recevant les données  
        For lig = 2 To NbrLig  
        com = .Cells(lig, 2).Value  
        Select Case com     'sélection des données à extraire présentes dans la variable com  
            Case "Ambarès-et-Lagrave", "Ambès", "Artigues-près-Bordeaux", "Bassens", "Bègles", "Blanquefort", "Bordeaux", "Bouliac", "Bruges", "Carbon-Blanc", "Cenon", "Eysines", "Floirac", "Gradignan", "Le Bouscat", "Le Haillan", "Le Taillan-Médoc", "Lormont", "Mérignac", "Parempuyre", "Pessac", "Saint-Aubin-de-Médoc", "Saint-Louis-de-Montferrand", "Saint-Médard-en-Jalles", "Saint-Vincent-de-Paul", "Talence", "Villenave-d'Ornon"  
                .Cells(lig, 1).EntireRow.Copy  
                NumLig = NumLig + 1  
                Cells(NumLig, 1).Select  
                ActiveSheet.Paste  
        End Select  
          
        Next  
      
    NumLig = 1  
      
    'on redimensionne les colonnes  
    Columns("A:DN").EntireColumn.AutoFit  
    'on se repositionne sur A1  
    Range("A1").Select  
      
    End With  
      
Next  


Application.CutCopyMode = False  
Workbooks("Données_Gironde.xls").Close  
Workbooks("Données_CUB2.xls").Close SaveChanges:=True  
Application.CutCopyMode = True  


End Sub