Public Sub Import()
Dim l_s_filePath As String
Dim l_o_wbData As Excel.Workbook
Dim l_o_wsData As Excel.Worksheet
Dim l_b_closeWbSrc As Boolean
Dim l_av_data() As Variant
'demander la sélection du fichier
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Sélection du fichier ""Data"" :"
.Filters.Clear
.Filters.Add "Fichier Excel", "*.xlsx"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Aucun fichier sélectionné. Action annulée.", vbExclamation, "Info"
GoTo QuitProc
End If
l_s_filePath = .SelectedItems(1)
End With
'récupérer le fichier
On Error Resume Next
Set l_o_wbData = Application.Workbooks(Split(l_s_filePath, "\")(UBound(Split(l_s_filePath, "\"))))
l_b_closeWbSrc = l_o_wbData Is Nothing
On Error GoTo 0
If l_b_closeWbSrc Then Set l_o_wbData = Application.Workbooks.Open(l_s_filePath, False, True)
'récupérer la feuille source de données (se nommant "Data")
On Error Resume Next
Set l_o_wsData = l_o_wbData.Worksheets("Data")
On Error GoTo 0
If l_o_wsData Is Nothing Then
MsgBox "La feuille source nommée ""Data"" n'a pas été trouvée dans le fichier. Action annulée.", vbExclamation, "Info"
GoTo QuitProc
End If
'extraire les données de la feuille source
l_av_data = ExtractData(Feuil1)
'créer un nouveau classeur et inscrire les données
With Application.Workbooks.Add(xlWBATWorksheet).Worksheets(1)
.Cells(1, 1).Value = "NumeroClient"
.Cells(1, 2).Value = "Intitule"
.Cells(1, 3).Value = "Raccourci"
.Cells(1, 4).Value = "Adresse1"
.Cells(1, 5).Value = "Adresse2"
.Cells(1, 6).Value = "CodePostal"
.Cells(1, 7).Value = "Complement"
.Cells(1, 8).Value = "Ville"
.Cells(1, 9).Value = "Country"
.Cells(1, 10).Value = "Client Profile"
.Cells(1, 11).Value = "Referral"
.Cells(1, 12).Value = "Sales Channel"
.Cells(1, 13).Value = "Language"
.Cells(1, 14).Value = "Title"
.Cells(1, 15).Value = "Contact"
.Cells(1, 16).Value = "Telephone"
.Cells(1, 17).Value = "Mobile"
.Cells(1, 18).Value = "Fax"
.Cells(1, 19).Value = "E-mail"
.Cells(1, 20).Value = "Discount Limo"
.Cells(1, 21).Value = "Special Deals Code"
.Cells(1, 22).Value = "Sales Person"
.Cells(2, 1).Resize(UBound(l_av_data, 1), UBound(l_av_data, 2)).Value = l_av_data
End With
QuitProc:
On Error Resume Next
If l_b_closeWbSrc Then l_o_wbData.Close False
Set l_o_wbData = Nothing
Set l_o_wsData = Nothing
End Sub
Private Function ExtractData(p_o_shData As Excel.Worksheet) As Variant()
Dim l_l_i As Long
Dim l_l_lastRow As Long
Dim l_l_nbItems As Long
Dim l_av_srcData() As Variant
Dim l_av_result() As Variant
With p_o_shData
'récupérer la dernière ligne de donnée
l_l_lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
'récupérer les données
l_av_srcData = .Range(.Cells(1, 1), .Cells(l_l_lastRow, 7)).Value
End With
'calculer le nombre d'entrées
l_l_nbItems = l_l_lastRow / 22
'préparer le tableau résultat
ReDim l_av_result(1 To l_l_nbItems, 1 To 22)
'boucler sur chaque entrée du tableau source
l_l_nbItems = 0
For l_l_i = 1 To l_l_lastRow Step 22
l_l_nbItems = l_l_nbItems + 1
l_av_result(l_l_nbItems, 1) = l_av_srcData(l_l_i + 2, 2) & l_av_srcData(l_l_i + 2, 3) 'NumeroClient
l_av_result(l_l_nbItems, 2) = l_av_srcData(l_l_i + 2, 7) 'Intitule
l_av_result(l_l_nbItems, 3) = l_av_srcData(l_l_i + 3, 2) & l_av_srcData(l_l_i + 3, 3) 'Raccourci
l_av_result(l_l_nbItems, 4) = l_av_srcData(l_l_i + 4, 2) & l_av_srcData(l_l_i + 4, 3) 'Adresse1
l_av_result(l_l_nbItems, 5) = l_av_srcData(l_l_i + 5, 2) & l_av_srcData(l_l_i + 5, 3) 'Adresse2
l_av_result(l_l_nbItems, 6) = l_av_srcData(l_l_i + 6, 2) & l_av_srcData(l_l_i + 6, 3) 'CodePostal
l_av_result(l_l_nbItems, 7) = l_av_srcData(l_l_i + 7, 2) & l_av_srcData(l_l_i + 7, 3) 'Complement
l_av_result(l_l_nbItems, 8) = l_av_srcData(l_l_i + 6, 5) 'Ville
l_av_result(l_l_nbItems, 9) = l_av_srcData(l_l_i + 8, 2) & l_av_srcData(l_l_i + 8, 3) 'Country
l_av_result(l_l_nbItems, 10) = l_av_srcData(l_l_i + 9, 2) & l_av_srcData(l_l_i + 9, 3) 'Client Profile
l_av_result(l_l_nbItems, 11) = l_av_srcData(l_l_i + 10, 2) & l_av_srcData(l_l_i + 10, 3) 'Referral
l_av_result(l_l_nbItems, 12) = l_av_srcData(l_l_i + 11, 2) & l_av_srcData(l_l_i + 11, 3) 'Sales Channel
l_av_result(l_l_nbItems, 13) = l_av_srcData(l_l_i + 12, 2) & l_av_srcData(l_l_i + 12, 3) 'Language
l_av_result(l_l_nbItems, 14) = l_av_srcData(l_l_i + 13, 2) & l_av_srcData(l_l_i + 13, 3) 'Title
l_av_result(l_l_nbItems, 15) = l_av_srcData(l_l_i + 14, 2) & l_av_srcData(l_l_i + 14, 3) 'Contact
l_av_result(l_l_nbItems, 16) = l_av_srcData(l_l_i + 15, 2) & l_av_srcData(l_l_i + 15, 3) 'Telephone
l_av_result(l_l_nbItems, 17) = l_av_srcData(l_l_i + 16, 2) & l_av_srcData(l_l_i + 16, 3) 'Mobile
l_av_result(l_l_nbItems, 18) = l_av_srcData(l_l_i + 17, 2) & l_av_srcData(l_l_i + 17, 3) 'Fax
l_av_result(l_l_nbItems, 19) = l_av_srcData(l_l_i + 18, 2) & l_av_srcData(l_l_i + 18, 3) 'E-mail
l_av_result(l_l_nbItems, 20) = l_av_srcData(l_l_i + 19, 2) & l_av_srcData(l_l_i + 19, 3) 'Discount Limo
l_av_result(l_l_nbItems, 21) = l_av_srcData(l_l_i + 20, 2) & l_av_srcData(l_l_i + 20, 3) 'Special Deals Code
l_av_result(l_l_nbItems, 22) = l_av_srcData(l_l_i + 21, 2) & l_av_srcData(l_l_i + 21, 3) 'Sales Person
Next l_l_i
ExtractData = l_av_result
End Function
