XL 2010 Extraction de données suivant onglets (msgbox)

GV91 · 1 Décembre 2020

Bonjour,

Ci-joint un code VBA me permettant une de faire une requête d'un fichier Excel source "AA", ce fichier source possédant 31 onglets soit un par jour.

Ici j'ai fait un test (concluant) sur le jour 2 (2$ en ligne 13), mon problème est que j'aimerai avoir une msgbox me permettant de modifier ce chiffre suivant le jour que je veux dans mon fichier source "AA"

Je n'arrive pas à incorporer ce paramètre dans mon code.

D'avance merci pour toute collaboration.

Sub Macro2()
'
' Macro2 Macro
'

'
With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=Array(Array( _
"ODBC;DSN=Excel Files;DBQ=C:\Users\Gravina.A\Desktop\test pour connexion\Suivi mouvements stock\2020\AA.xlsm;DefaultDir=C:\Users\Grav" _
), Array( _
"ina.A\Desktop\test pour connexion\Suivi mouvements stock\2020;DriverId=1046;MaxBufferSize=2048;PageTimeout=5;" _
)), Destination:=Range("$A$3")).QueryTable
.CommandText = Array( _
"SELECT `'2$'`.Date, `'2$'`.Emplacement, `'2$'`.Motif" & Chr(13) & "" & Chr(10) & "FROM `'2$'` `'2$'`")
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.ListObject.DisplayName = _
"Tableau_Lancer_la_requête_à_partir_de_Excel_Files"
.Refresh BackgroundQuery:=False
End With
ActiveWindow.SmallScroll Down:=-27
ActiveSheet.ListObjects("Tableau_Lancer_la_requête_à_partir_de_Excel_Files"). _
Range.AutoFilter Field:=3, Criteria1:="8 Casse entrepôt"
ActiveWorkbook.Worksheets("Feuil1").ListObjects( _
"Tableau_Lancer_la_requête_à_partir_de_Excel_Files").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Feuil1").ListObjects( _
"Tableau_Lancer_la_requête_à_partir_de_Excel_Files").Sort.SortFields.Add Key _
:=Range( _
"Tableau_Lancer_la_requête_à_partir_de_Excel_Files[[#All],[Emplacement]]"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Feuil1").ListObjects( _
"Tableau_Lancer_la_requête_à_partir_de_Excel_Files").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

Hasco · 2 Décembre 2020

Bonjour

Vous pouvez toujours essayer les lignes ci-dessous.
sans fichier difficile de tester plus avant.

VB:

Sub Macro2()
'
' Macro2 Macro
'

'
Const SQL_Base As String = "SELECT `'2$'`.Date, `'2$'`.Emplacement, `'2$'`.Motif FROM `'2$'` AS `'2$'`;"
Dim SQL As String
Dim rep As Variant
rep = Application.InputBox("Entrez le numéro de jour désiré", "Interrogation base de données", 0, Type:=1)

If rep <> False And rep >= 1 And rep <= 31 Then SQL = Replace(SQL_Base, "2", CStr(rep))

With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=Array(Array( _
"ODBC;DSN=Excel Files;DBQ=C:\Users\Gravina.A\Desktop\test pour connexion\Suivi mouvements stock\2020\AA.xlsm;DefaultDir=C:\Users\Grav" _
), Array( _
"ina.A\Desktop\test pour connexion\Suivi mouvements stock\2020;DriverId=1046;MaxBufferSize=2048;PageTimeout=5;" _
)), Destination:=Range("$A$3")).QueryTable
.CommandText = Array(SQL)
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.ListObject.DisplayName = _
"Tableau_Lancer_la_requête_à_partir_de_Excel_Files"
.Refresh BackgroundQuery:=False
End With
ActiveWindow.SmallScroll Down:=-27
ActiveSheet.ListObjects("Tableau_Lancer_la_requête_à_partir_de_Excel_Files"). _
Range.AutoFilter Field:=3, Criteria1:="8 Casse entrepôt"
ActiveWorkbook.Worksheets("Feuil1").ListObjects( _
"Tableau_Lancer_la_requête_à_partir_de_Excel_Files").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Feuil1").ListObjects( _
"Tableau_Lancer_la_requête_à_partir_de_Excel_Files").Sort.SortFields.Add Key _
:=Range( _
"Tableau_Lancer_la_requête_à_partir_de_Excel_Files[[#All],[Emplacement]]"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Feuil1").ListObjects( _
"Tableau_Lancer_la_requête_à_partir_de_Excel_Files").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

GV91 · 2 Décembre 2020

Bonjour @Roblochon
Merci pour ta réponse, le code est top !

XL 2010 Extraction de données suivant onglets (msgbox)

GV91

XLDnaute Junior

Hasco

XLDnaute Barbatruc

GV91

XLDnaute Junior

Discussions similaires