Première donnée à droite
a
Bonjour,
Je viens chercher de l'aide sur une macro que j'ai mais que je n'ai pas créée (trop complexe
Voilà la partie de mon code :
If aa(i, 3) = "Opérateur" Then
Fin = Sh.Cells(Rows.count, 1).End(3).Row + 1
If Fin < 11 Then Fin = 11
Sh.Cells(Fin, 1) = Mid(Split(aa(i, 10), "(")(1), 1, Len(Split(aa(i, 10), "(")(1)) - 1) 'A
Sh.Cells(Fin, 2) = Trim(Split(aa(i, 10), "(")(0)) 'B
Sh.Cells(Fin, 3) = aa(i + 5, 16)
Sh.Cells(Fin, 4) = aa(i + 7, 16)Actuellement, ca récupère sur la 16ème colonne les données.
Malheureusement, les données sont parfois décalées un peu sur la droite de quelques colonnes.
Je souhaite donc savoir s'il est possible que la macro cherche en colonne "16" et que s'il n'y a rien, elle se décale sur la droite jusqu'à trouver une donnée.
Savez vous comment faire cela?
Merci par avance pour votre aide,
Excellente journée,
Loïc
Bonjour Loïc, bonjour le forum,
Difficile de pouvoir t'aider avec à peine un bout de code... À défaut du fichier, au moins le code intégral !...
a
Bonjour,
Je te mets le code ci-dessous.
Il est très long alors je n'osais pas tout mettre
Merci pour ta réponse et ton aide,
Bonne journée,
Loïc
Option Explicit
Sub Bouton1_Cliquer()
Call stat
End Sub
Sub Bouton2_Cliquer()
Sheets("Importation des statistiques").Unprotect ("oiir")
With Feuil1
.Cells(6, 5) = "": .Cells(6, 7) = ""
.Range(.Cells(10, 1), .Cells(2000, 54)).ClearContents
Sheets("Importation des statistiques").Protect ("oiir")
End With
End Sub
Sub stat()
Dim fd As Object, Fichier$, nom$, wbks As Workbook, Fin&, aa, a&, i&, wbkc As Workbook, Sh As Worksheet, mem&, t$
Set wbkc = ThisWorkbook
Set fd = Application.FileDialog(1)
Sheets("Importation des statistiques").Unprotect ("oiir")
With fd
Fichier = ThisWorkbook.Path
.Title = "Choisissez le Fichier du quel vous Souhaitez Importer les Inscriptions"
.InitialFileName = Fichier
.ButtonName = "Importer"
.Filters.Clear
.Filters.Add "Fichier Excel", "*.xls"
.AllowMultiSelect = False
If .Show <> 0 Then
nom = .SelectedItems(1)
Set wbks = Workbooks.Open(nom)
Fin = wbks.ActiveSheet.Cells.Find("*", , xlValues, , 1, 2, 0).Row
aa = wbks.ActiveSheet.Range("A1:AA" & Fin)
wbks.Close
Else
MsgBox "Vous n'avez choisi aucun fichier", , "Manque de Fichier": Exit Sub
End If
End With
Application.ScreenUpdating = 0
t = Timer
Set Sh = wbkc.Sheets("Importation des statistiques")
For i = 1 To UBound(aa)
If aa(i, 2) = "Page" Then mem = aa(i, 10)
If aa(i, 3) = "Période" Then
Sh.Cells(6, 5) = aa(i + 1, 11)
Sh.Cells(6, 7) = aa(i + 2, 11)
End If
If aa(i, 3) = "Sélection" Then
Sh.Cells(6, 5) = aa(i, 11)
Sh.Cells(6, 7) = aa(i + 1, 11)
End If
If aa(i, 3) = "Opérateur" Then
Fin = Sh.Cells(Rows.count, 1).End(3).Row + 1
If Fin < 11 Then Fin = 11
Sh.Cells(Fin, 1) = Mid(Split(aa(i, 10), "(")(1), 1, Len(Split(aa(i, 10), "(")(1)) - 1) 'A
Sh.Cells(Fin, 2) = Trim(Split(aa(i, 10), "(")(0)) 'B
Sh.Cells(Fin, 3) = aa(i + 5, 16)
Sh.Cells(Fin, 4) = aa(i + 7, 16)
Sh.Cells(Fin, 5) = aa(i + 8, 16)
Sh.Cells(Fin, 6) = aa(i + 11, 16)
Sh.Cells(Fin, 7) = Round(aa(i + 13, 16), 2)
Sh.Cells(Fin, 8) = aa(i + 15, 16)
Sh.Cells(Fin, 9) = aa(i + 16, 16)
Sh.Cells(Fin, 10) = aa(i + 18, 16)
Sh.Cells(Fin, 11) = aa(i + 19, 16)
Sh.Cells(Fin, 12) = aa(i + 20, 16)
Sh.Cells(Fin, 13) = aa(i + 21, 16)
Sh.Cells(Fin, 14) = aa(i + 22, 16)
Sh.Cells(Fin, 15) = aa(i + 24, 16)
Sh.Cells(Fin, 16) = aa(i + 27, 16)
Sh.Cells(Fin, 17) = aa(i + 31, 16)
Sh.Cells(Fin, 18) = aa(i + 32, 16)
Sh.Cells(Fin, 19) = aa(i + 35, 16)
Sh.Cells(Fin, 20) = aa(i + 38, 16)
Sh.Cells(Fin, 21) = aa(i + 39, 16)
Sh.Cells(Fin, 22) = aa(i + 45, 13)
Sh.Cells(Fin, 23) = aa(i + 46, 13)
Sh.Cells(Fin, 24) = aa(i + 47, 13)
Sh.Cells(Fin, 25) = aa(i + 5, 26)
Sh.Cells(Fin, 26) = aa(i + 6, 26)
Sh.Cells(Fin, 27) = aa(i + 7, 26)
Sh.Cells(Fin, 28) = aa(i + 9, 26)
Sh.Cells(Fin, 29) = aa(i + 11, 26)
Sh.Cells(Fin, 30) = aa(i + 13, 26)
Sh.Cells(Fin, 31) = aa(i + 14, 26)
Sh.Cells(Fin, 32) = aa(i + 15, 26)
Sh.Cells(Fin, 33) = aa(i + 16, 26)
Sh.Cells(Fin, 34) = aa(i + 18, 26)
Sh.Cells(Fin, 35) = aa(i + 19, 26)
Sh.Cells(Fin, 36) = aa(i + 20, 26)
Sh.Cells(Fin, 37) = aa(i + 21, 26)
Sh.Cells(Fin, 38) = aa(i + 23, 26)
Sh.Cells(Fin, 39) = aa(i + 25, 26)
Sh.Cells(Fin, 40) = aa(i + 27, 26)
Sh.Cells(Fin, 41) = aa(i + 29, 26)
Sh.Cells(Fin, 42) = aa(i + 31, 26)
Sh.Cells(Fin, 43) = aa(i + 32, 26)
Sh.Cells(Fin, 44) = aa(i + 34, 26)
Sh.Cells(Fin, 45) = aa(i + 39, 25)
Sh.Cells(Fin, 46) = aa(i + 41, 25)
Sh.Cells(Fin, 47) = aa(i + 45, 26)
Sh.Cells(Fin, 48) = aa(i + 46, 26)
Sh.Cells(Fin, 49) = aa(i + 47, 26)
Sh.Cells(Fin, 50) = aa(i + 48, 26)
Sh.Cells(Fin, 51) = aa(i + 51, 26)
Sh.Cells(Fin, 52) = aa(i + 54, 26)
i = i + 55
End If
Next i
'sh.Cells.Replace What:=0, Replacement:="", LookAt:=xlWhole
On Error Resume Next
For i = 3 To 52
Sh.Cells(10, i) = Application.WorksheetFunction.Average(Sh.Range(Sh.Cells(11, i), Sh.Cells(Fin, i)))
Sh.Cells(10, i) = Round(Sh.Cells(10, i), 2)
If Sh.Cells(10, i) = 0 Then Sh.Cells(10, i) = ""
Next i
Sh.Cells(10, 1) = "Moyenne de la Colonne": Sh.Cells(10, 1).Font.ColorIndex = 3
Application.ScreenUpdating = 1
Application.Run _
"StatsFormules"
Sheets("Importation des statistiques").Protect ("oiir")
MsgBox "Le traitement des " & mem & " Pages à été effectué en " & Format(Timer - t, "0.00 s"), , "C'est Terminé"
End SubRe,
Je pense avoir isolé ce qui concernait la colonne 16 mais la proposition que je te fais implique qu'il y ait toujours une valeur en colonne 16 ou dans les autres sinon ça va planter...
le code modifié :
Sub stat()
Dim fd As Object, Fichier$, nom$, wbks As Workbook, Fin&, aa, a&, i&, wbkc As Workbook, Sh As Worksheet, mem&, t$
Set wbkc = ThisWorkbook
Set fd = Application.FileDialog(1)
Sheets("Importation des statistiques").Unprotect ("oiir")
With fd
Fichier = ThisWorkbook.Path
.Title = "Choisissez le Fichier du quel vous Souhaitez Importer les Inscriptions"
.InitialFileName = Fichier
.ButtonName = "Importer"
.Filters.Clear
.Filters.Add "Fichier Excel", "*.xls"
.AllowMultiSelect = False
If .Show <> 0 Then
nom = .SelectedItems(1)
Set wbks = Workbooks.Open(nom)
Fin = wbks.ActiveSheet.Cells.Find("*", , xlValues, , 1, 2, 0).Row
aa = wbks.ActiveSheet.Range("A1:AA" & Fin)
wbks.Close
Else
MsgBox "Vous n'avez choisi aucun fichier", , "Manque de Fichier": Exit Sub
End If
End With
Application.ScreenUpdating = 0
t = Timer
Set Sh = wbkc.Sheets("Importation des statistiques")
For i = 1 To UBound(aa)
If aa(i, 2) = "Page" Then mem = aa(i, 10)
If aa(i, 3) = "Période" Then
Sh.Cells(6, 5) = aa(i + 1, 11)
Sh.Cells(6, 7) = aa(i + 2, 11)
End If
If aa(i, 3) = "Sélection" Then
Sh.Cells(6, 5) = aa(i, 11)
Sh.Cells(6, 7) = aa(i + 1, 11)
End If
If aa(i, 3) = "Opérateur" Then
Fin = Sh.Cells(Rows.Count, 1).End(3).Row + 1
If Fin < 11 Then Fin = 11
Sh.Cells(Fin, 1) = Mid(Split(aa(i, 10), "(")(1), 1, Len(Split(aa(i, 10), "(")(1)) - 1) 'A
Sh.Cells(Fin, 2) = Trim(Split(aa(i, 10), "(")(0)) 'B
'***************************************************
Dim x As Byte 'à remettre en haut avec les déclarations de variables
x = 16: Do
Sh.Cells(Fin, 3) = aa(i + 5, x): x = x + 1
Loop While Sh.Cells(Fin, 3) = ""
x = 16: Do
Sh.Cells(Fin, 4) = aa(i + 7, x): x = x + 1
Loop While Sh.Cells(Fin, 4) = ""
x = 16: Do
Sh.Cells(Fin, 5) = aa(i + 8, x): x = x + 1
Loop While Sh.Cells(Fin, 5) = ""
x = 16: Do
Sh.Cells(Fin, 6) = aa(i + 11, x): x = x + 1
Loop While Sh.Cells(Fin, 6) = ""
x = 16: Do
Sh.Cells(Fin, 7) = Round(aa(i + 13, x), 2): x = x + 1
Loop While Sh.Cells(Fin, 7) = ""
x = 16: Do
Sh.Cells(Fin, 8) = aa(i + 15, x): x = x + 1
Loop While Sh.Cells(Fin, 8) = ""
x = 16: Do
Sh.Cells(Fin, 9) = aa(i + 16, x): x = x + 1
Loop While Sh.Cells(Fin, 9) = ""
x = 16: Do
Sh.Cells(Fin, 10) = aa(i + 18, x): x = x + 1
Loop While Sh.Cells(Fin, 10) = ""
x = 16: Do
Sh.Cells(Fin, 11) = aa(i + 19, x): x = x + 1
Loop While Sh.Cells(Fin, 11) = ""
x = 16: Do
Sh.Cells(Fin, 12) = aa(i + 20, x): x = x + 1
Loop While Sh.Cells(Fin, 12) = ""
x = 16: Do
Sh.Cells(Fin, 13) = aa(i + 21, x): x = x + 1
Loop While Sh.Cells(Fin, 13) = ""
x = 16: Do
Sh.Cells(Fin, 14) = aa(i + 22, x): x = x + 1
Loop While Sh.Cells(Fin, 14) = ""
x = 16: Do
Sh.Cells(Fin, 15) = aa(i + 24, x): x = x + 1
Loop While Sh.Cells(Fin, 15) = ""
x = 16: Do
Sh.Cells(Fin, 16) = aa(i + 27, x): x = x + 1
Loop While Sh.Cells(Fin, 16) = ""
x = 16: Do
Sh.Cells(Fin, 17) = aa(i + 31, x): x = x + 1
Loop While Sh.Cells(Fin, 17) = ""
x = 16: Do
Sh.Cells(Fin, 18) = aa(i + 32, x): x = x + 1
Loop While Sh.Cells(Fin, 18) = ""
x = 16: Do
Sh.Cells(Fin, 19) = aa(i + 35, x): x = x + 1
Loop While Sh.Cells(Fin, 19) = ""
x = 16: Do
Sh.Cells(Fin, 20) = aa(i + 38, x): x = x + 1
Loop While Sh.Cells(Fin, 20) = ""
x = 16: Do
Sh.Cells(Fin, 21) = aa(i + 39, x): x = x + 1
Loop While Sh.Cells(Fin, 21) = ""
'***************************************************
Sh.Cells(Fin, 22) = aa(i + 45, 13)
Sh.Cells(Fin, 23) = aa(i + 46, 13)
Sh.Cells(Fin, 24) = aa(i + 47, 13)
Sh.Cells(Fin, 25) = aa(i + 5, 26)
Sh.Cells(Fin, 26) = aa(i + 6, 26)
Sh.Cells(Fin, 27) = aa(i + 7, 26)
Sh.Cells(Fin, 28) = aa(i + 9, 26)
Sh.Cells(Fin, 29) = aa(i + 11, 26)
Sh.Cells(Fin, 30) = aa(i + 13, 26)
Sh.Cells(Fin, 31) = aa(i + 14, 26)
Sh.Cells(Fin, 32) = aa(i + 15, 26)
Sh.Cells(Fin, 33) = aa(i + 16, 26)
Sh.Cells(Fin, 34) = aa(i + 18, 26)
Sh.Cells(Fin, 35) = aa(i + 19, 26)
Sh.Cells(Fin, 36) = aa(i + 20, 26)
Sh.Cells(Fin, 37) = aa(i + 21, 26)
Sh.Cells(Fin, 38) = aa(i + 23, 26)
Sh.Cells(Fin, 39) = aa(i + 25, 26)
Sh.Cells(Fin, 40) = aa(i + 27, 26)
Sh.Cells(Fin, 41) = aa(i + 29, 26)
Sh.Cells(Fin, 42) = aa(i + 31, 26)
Sh.Cells(Fin, 43) = aa(i + 32, 26)
Sh.Cells(Fin, 44) = aa(i + 34, 26)
Sh.Cells(Fin, 45) = aa(i + 39, 25)
Sh.Cells(Fin, 46) = aa(i + 41, 25)
Sh.Cells(Fin, 47) = aa(i + 45, 26)
Sh.Cells(Fin, 48) = aa(i + 46, 26)
Sh.Cells(Fin, 49) = aa(i + 47, 26)
Sh.Cells(Fin, 50) = aa(i + 48, 26)
Sh.Cells(Fin, 51) = aa(i + 51, 26)
Sh.Cells(Fin, 52) = aa(i + 54, 26)
i = i + 55
End If
Next i
'sh.Cells.Replace What:=0, Replacement:="", LookAt:=xlWhole
On Error Resume Next
For i = 3 To 52
Sh.Cells(10, i) = Application.WorksheetFunction.Average(Sh.Range(Sh.Cells(11, i), Sh.Cells(Fin, i)))
Sh.Cells(10, i) = Round(Sh.Cells(10, i), 2)
If Sh.Cells(10, i) = 0 Then Sh.Cells(10, i) = ""
Next i
Sh.Cells(10, 1) = "Moyenne de la Colonne": Sh.Cells(10, 1).Font.ColorIndex = 3
Application.ScreenUpdating = 1
Application.Run _
"StatsFormules"
Sheets("Importation des statistiques").Protect ("oiir")
MsgBox "Le traitement des " & mem & " Pages à été effectué en " & Format(Timer - t, "0.00 s"), , "C'est Terminé"
End Suba
Re-bonjour
J'avais voulu simplifier ma demande mais du coup je ne sais pas rattrapper l'ensemble
Voila exactement ce dont j'ai besoin.
Concrètement cette macro va chercher sur un doc des données qui sont rangées en 2 colonnes.
La colonne de gauche commence à 16 mais peut etre en 17,18,19 ou même plus
De la même facon la colonne de droite commence à minimum 26 mais peut aller plus à droite encore.
Il y a même des données sur la colonne de droite ou de gauche en colonne X et une seule (ou plusieurs) autre donnée en Y...
Et ce pour l'ensemble des données :s
Je ne sais pas si c'est faisable
Merci encore pour l'aide,
Excellente journée,
Loïc