1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83
| Option Explicit
Sub Reprendre()
Dim fd As Office.FileDialog, sFile As String
Dim wbData As Workbook, wshData As Worksheet, rData As Range, sData As String
Dim kEtu As Long, kExe As Long, kMar As Long, nR As Long
Dim kEtuD As Long, kExeD As Long, kMarD As Long, nRD As Long
Dim sFml As String
Dim kRow1 As Long, kRow2 As Long, kRow1D As Long, kRow2D As Long
'--- recherche n° ligne des titres dans feuille courante
'--- suppose titre "Numéro de dossier" en colonne A
kRow1 = Application.WorksheetFunction.Match("Numéro de dossier", Range("A:A"), 0)
'--- recherche n° colonnes dans feuille en cours
kEtu = Application.WorksheetFunction.Match("Etude", Rows(kRow1), 0)
kExe = Application.WorksheetFunction.Match("Exe", Rows(kRow1), 0)
kMar = Application.WorksheetFunction.Match("Marches", Rows(kRow1), 0)
kRow1 = kRow1 + 1 '--- première ligne avec des données
kRow2 = Range("A" & Rows.Count).End(xlUp).Row '--- dernière ligne (qui n'est pas une donnée mais indique le nb de dossiers)
kRow2 = kRow2 - 1 '--- dernière ligne avec des données
Debug.Print kRow1, kRow2, kEtu, kExe, kMar '--- pour info
'--- sélection du fichier antérieur
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Clear
.Filters.Add "Fichiers Excel", "*.xls*", 1
.Title = "Choisir un fichier Excel"
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path
If .Show = True Then
sFile = .SelectedItems(1)
Debug.Print sFile
Set wbData = Application.Workbooks.Open(sFile)
Set wshData = wbData.Worksheets(1)
Set fd = Nothing
Else
MsgBox "Annulé", , "Pour info"
Set fd = Nothing
Exit Sub
End If
End With
'--- recherche n° ligne des titres dans wshData
'--- suppose "Numéro de dossier" en colonne A
kRow1D = Application.WorksheetFunction.Match("Numéro de dossier", wshData.Range("A:A"), 0)
'--- recherche n° colonnes dans wshData
kEtuD = Application.WorksheetFunction.Match("Etude", wshData.Rows(kRow1D), 0)
kExeD = Application.WorksheetFunction.Match("Exe", wshData.Rows(kRow1D), 0)
kMarD = Application.WorksheetFunction.Match("Marches", wshData.Rows(kRow1D), 0)
kRow1D = kRow1D + 1 '--- n° première ligne avec des données
kRow2D = wshData.Range("A" & wshData.Rows.Count).End(xlUp).Row
kRow2D = kRow2D - 1 '--- n° dernière ligne avec des données
Debug.Print kRow1D, kRow2D, kEtuD, kExeD, kMarD '--- pour info
'--- dénomination de la plage de recherche
Set rData = wshData.Range(wshData.Cells(kRow1D, 1), wshData.Cells(kRow2D, Application.WorksheetFunction.Max(kEtuD, kExeD, kMarD)))
Debug.Print wbData.Path, wbData.Name, wshData.Name, rData.Address '--- pour info
sData = "'" & wbData.Path & "\[" & wbData.Name & "]" & wshData.Name & "'!" & rData.Address
Debug.Print sData '--- pour info
wbData.Close
'--- inscription formules
sFml = "=IFERROR(VLOOKUP($A" & kRow1 & "," & sData & ", 000, FALSE),"""")"
'--- dans Etude
Cells(kRow1, kEtu).Formula = Replace(sFml, "000", kEtuD)
Cells(kRow1, kEtu).Copy '--- copie formules
Range(Cells(kRow1, kEtu), Cells(kRow2, kEtu)).PasteSpecial xlPasteFormulas
Range(Cells(kRow1, kEtu), Cells(kRow2, kEtu)).Copy '--- copie résultats (valeurs)
Range(Cells(kRow1, kEtu), Cells(kRow2, kEtu)).PasteSpecial xlPasteValues
'--- dans Exe
Cells(kRow1, kExe).Formula = Replace(sFml, "000", kExeD)
Cells(kRow1, kExe).Copy '--- copie formules
Range(Cells(kRow1, kExe), Cells(kRow2, kExe)).PasteSpecial xlPasteFormulas
Range(Cells(kRow1, kExe), Cells(kRow2, kExe)).Copy '--- copie résultats (valeurs)
Range(Cells(kRow1, kExe), Cells(kRow2, kExe)).PasteSpecial xlPasteValues
'--- dans Marche
Cells(kRow1, kMar).Formula = Replace(sFml, "000", kMarD)
Cells(kRow1, kMar).Copy '--- copie formules
Range(Cells(kRow1, kMar), Cells(kRow2, kMar)).PasteSpecial xlPasteFormulas
Range(Cells(kRow1, kMar), Cells(kRow2, kMar)).Copy '--- copie résultats (valeurs)
Range(Cells(kRow1, kMar), Cells(kRow2, kMar)).PasteSpecial xlPasteValues
'--- cloture
Set rData = Nothing
Set wshData = Nothing
Set wbData = Nothing
MsgBox "Valeurs inscrites.", , "Pour info"
End Sub |
Partager