boucle

B

BIL boud

XLDnaute Occasionnel
bonjour

jai un code qui fonctionne bien, il recupere/stoke des données a partir des feuilles qui se trouvent dans le mm classeur
mon probleme c que jai du mal a ladapter pour quil recupere/stocker les données a partir des autres classeurs
sachant que tt les feuilles des autres classeurs ont la mm appelation que celui la

la recuperation de donnée ce faite en fonction du projet (range("E2")) et/ou range("f2")ou en fonction du noms range("e1") et/ou range("f1")

voici le code

_______________________________________________________________________________________________________________________________________________________________________
Sub reading_activities()

Application.ScreenUpdating = False



Dim i As Double
Dim j As Double
Dim k As Double
Dim test_people1 As Boolean
Dim test_people2 As Boolean
Dim test_project1 As Boolean
Dim test_project2 As Boolean
Dim is_people As Boolean
Dim is_project As Boolean


color_headers = Worksheets("NEW_VB_config").Range("g1").Interior.ColorIndex
color_running = Worksheets("NEW_VB_config").Range("g2").Interior.ColorIndex
color_late = Worksheets("NEW_VB_config").Range("g3").Interior.ColorIndex
color_comments = Worksheets("NEW_VB_config").Range("g4").Interior.ColorIndex
color_currentcw = Worksheets("NEW_VB_config").Range("g5").Interior.ColorIndex
color_empty = Worksheets("NEW_VB_config").Range("g6").Interior.ColorIndex
color_end = Worksheets("NEW_VB_config").Range("g7").Interior.ColorIndex
color_prio1 = Worksheets("NEW_VB_config").Range("g9").Interior.ColorIndex
color_prio2 = Worksheets("NEW_VB_config").Range("g10").Interior.ColorIndex
color_prio3 = Worksheets("NEW_VB_config").Range("g11").Interior.ColorIndex
color_prio4 = Worksheets("NEW_VB_config").Range("g12").Interior.ColorIndex

'this one is used in order to add some informations in the sheet, if it's no more columns available, so be careful before using this !

added_columns = 3

nb_speciality = 11
speciality1 = Worksheets("NEW_VB_config").Range("o2").Value
speciality2 = Worksheets("NEW_VB_config").Range("o3").Value
speciality3 = Worksheets("NEW_VB_config").Range("o4").Value
speciality4 = Worksheets("NEW_VB_config").Range("o5").Value
speciality5 = Worksheets("NEW_VB_config").Range("o6").Value
speciality6 = Worksheets("NEW_VB_config").Range("o7").Value
speciality7 = Worksheets("NEW_VB_config").Range("o8").Value
speciality8 = Worksheets("NEW_VB_config").Range("o9").Value
speciality9 = Worksheets("NEW_VB_config").Range("o10").Value
speciality10 = Worksheets("NEW_VB_config").Range("o11").Value
speciality11 = Worksheets("NEW_VB_config").Range("o12").Value

ReDim list_speciality(nb_speciality - 1)
list_speciality(0) = speciality1
list_speciality(1) = speciality2
list_speciality(2) = speciality3
list_speciality(3) = speciality4
list_speciality(4) = speciality5
list_speciality(5) = speciality6
list_speciality(6) = speciality7
list_speciality(7) = speciality8
list_speciality(8) = speciality9
list_speciality(9) = speciality10
list_speciality(10) = speciality11

nb_type = 7
type1 = "people"
type2 = "wltc20"
type3 = "wltc_7"
type4 = "BRC_7"
type5 = "BRC2h"
type6 = "cal2h"
type7 = "workshop"


erase_data


'writing weeks at the top of the columns

'numbers of weeks in absolute
date_begin = Int(Worksheets("MAP1").Range("e3").Value) * 52 + Round(100 * (Worksheets("MAP1").Range("e3").Value - Int(Worksheets("MAP1").Range("e3").Value)))
date_end = Int(Worksheets("MAP1").Range("e4").Value) * 52 + Round(100 * (Worksheets("MAP1").Range("e4").Value - Int(Worksheets("MAP1").Range("e4").Value)))

Worksheets("MAP1").Range("b10:u11").Interior.ColorIndex = color_headers


Dim n As Integer
Dim nb_av As Integer
Dim ns As Integer



'search the first week corresponding
ns = 0
While Worksheets("MAP1").Range("e3").Value <> Worksheets("Synthese_conges_SS_TAD").Range("b1").offset(0, ns).Value And ns < date_end - date_begin
ns = ns + 1
Wend

nb_av = 0
While LCase(Worksheets("Synthese_conges_SS_TAD").Range("a2").offset(nb_av).Value) <> LCase(Worksheets("MAP1").Range("e1").Value) And Worksheets("Synthese_conges_SS_TAD").Range("a2").offset(nb_av).Value <> ""
nb_av = nb_av + 1
Wend

'MsgBox (ns)
'MsgBox (nb_av)

Worksheets("MAP1").Range("q10:dd11").offset(0, added_columns) = ""
For n = 0 To date_end - date_begin
Worksheets("MAP1").Range("q11").offset(0, added_columns + n + 1).Value = (Round(100 * (Worksheets("MAP1").Range("e3").Value - Int(Worksheets("MAP1").Range("e3").Value))) + n - 1) Mod 52 + 1
Worksheets("MAP1").Range("q11").offset(0, added_columns + n + 1).Interior.ColorIndex = color_headers
Worksheets("MAP1").Range("q11").offset(-1, added_columns + n + 1).Interior.ColorIndex = color_headers

'write availability of the calibrator
Worksheets("MAP1").Range("q6").offset(0, added_columns + n + 1).Value = Worksheets("Synthese_conges_SS_TAD").Range("b1").offset(nb_av + 1, ns + n).Value

Next n



'searching in the speciality sheets to writes activities of the "people" guy in the sheet





people = Worksheets("MAP1").Range("e1").Value
project = Worksheets("MAP1").Range("e2").Value
people2 = Worksheets("MAP1").Range("f1").Value
project2 = Worksheets("MAP1").Range("f2").Value

'write something else in project2 or people2 if blank, to not keep blank values
If people2 = "" Then
people2 = "aaaaa"
End If
If project2 = "" Then
project2 = "aaaaa"
End If

'msgBox (nb_speciality)
'MsgBox (list_speciality(1))

'speciality = speciality1
'speciality = list_speciality(0)

'MsgBox (LCase(people))
'MsgBox (UCase(people))
'MsgBox (UCase(Worksheets("Planification_EOBD_matrices").Range("d2").Offset(69).Text))
'Dim test_project_people As Boolean

'If Worksheets("MAP1").Range("c1").Value = "x" Then
'test_project_people = LCase(Worksheets(speciality).Range("d2").Offset(i).Text) = LCase(people)
'Else
'test_project_people = LCase(Worksheets(speciality).Range("a2").Offset(i).Text) = LCase(project)
'End If


tampon_ligne = 0
k = 0
n = 0
While list_speciality(n) <> ""
'For n = 0 To nb_speciality - 1
speciality = list_speciality(n)
Worksheets(speciality).AutoFilterMode = False

i = 0

'MsgBox (people)



While Worksheets(speciality).Range("a2").offset(i, 0).Value <> ""


'test if the activity if for the rigth person and also if the date is in the range

is_people = Worksheets("MAP1").Range("c1").Value = "x"
is_project = Worksheets("MAP1").Range("c2").Value = "x"
test_people1 = LCase(Worksheets(speciality).Range("d2").offset(i).Text) = LCase(people)
test_people2 = LCase(Worksheets(speciality).Range("d2").offset(i).Text) = LCase(people2)
test_project1 = LCase(Worksheets(speciality).Range("a2").offset(i).Text) = LCase(project)
test_project2 = LCase(Worksheets(speciality).Range("a2").offset(i).Text) = LCase(project2)



If is_people And test_people1 Or is_people And test_people2 Or is_project And test_project1 Or is_project And test_project2 Then
'If True Then

'test date after testing the person
year_begin = Int(Worksheets(speciality).Range("h2").offset(i))
year_end = Int(Worksheets(speciality).Range("j2").offset(i))
year_realend = Int(Worksheets(speciality).Range("l2").offset(i))
cw_begin = Round(100 * (Worksheets(speciality).Range("h2").offset(i) - Int(Worksheets(speciality).Range("h2").offset(i))))
cw_end = Round(100 * (Worksheets(speciality).Range("j2").offset(i) - Int(Worksheets(speciality).Range("j2").offset(i))))
cw_realend = Round(100 * (Worksheets(speciality).Range("l2").offset(i) - Int(Worksheets(speciality).Range("l2").offset(i))))
activity_begin = year_begin * 52 + cw_begin
activity_end = year_end * 52 + cw_end
activity_realend = year_realend * 52 + cw_realend

If activity_realend >= date_begin Then
'If True Then


'projet
Worksheets("MAP1").Range("d12").offset(k) = Worksheets(speciality).Range("a2").offset(i)
'activite et sous activite resp speciality
Worksheets("MAP1").Range("e12").offset(k) = Worksheets(speciality).Range("b2").offset(i)
Worksheets("MAP1").Range("f12").offset(k) = speciality
Worksheets("MAP1").Range("g12").offset(k) = Worksheets(speciality).Range("d2").offset(i)
Worksheets("MAP1").Range("h12").offset(k) = Worksheets(speciality).Range("e2").offset(i)
Worksheets("MAP1").Range("i12").offset(k) = Worksheets(speciality).Range("f2").offset(i)
'weeks
Worksheets("MAP1").Range("k12").offset(k) = Worksheets(speciality).Range("h2").offset(i)
Worksheets("MAP1").Range("l12").offset(k) = Worksheets(speciality).Range("j2").offset(i)
Worksheets("MAP1").Range("m12").offset(k) = Worksheets(speciality).Range("l2").offset(i)

'tag
Worksheets("MAP1").Range("j12").offset(k) = Worksheets(speciality).Range("ab2").offset(i)



'DOCINFO LINK IN W
Worksheets("MAP1").Range("p12").offset(k) = Worksheets(speciality).Range("w2").offset(i)

'priority
Worksheets("MAP1").Range("b12").offset(k) = Worksheets(speciality).Range("ah2").offset(i)
'color for priority
If Worksheets("MAP1").Range("b12").offset(k) = 1 Then
Worksheets("MAP1").Range("12:12").offset(k).Interior.ColorIndex = color_prio1
ElseIf Worksheets("MAP1").Range("b12").offset(k) = 2 Then
Worksheets("MAP1").Range("12:12").offset(k).Interior.ColorIndex = color_prio2
ElseIf Worksheets("MAP1").Range("b12").offset(k) = 3 Then
Worksheets("MAP1").Range("12:12").offset(k).Interior.ColorIndex = color_prio3
ElseIf Worksheets("MAP1").Range("b12").offset(k) = 4 Then
Worksheets("MAP1").Range("12:12").offset(k).Interior.ColorIndex = color_prio4
End If


'ended
'2 choices are "Oui" or "Non"
If Worksheets(speciality).Range("t2").offset(i).Value = "Oui" Then
Worksheets("MAP1").Range("c12").offset(k).Value = "x"
Worksheets("MAP1").Range("12:12").offset(k).Interior.ColorIndex = color_end
End If

'comment
Worksheets("MAP1").Range("s12").offset(k) = Worksheets(speciality).Range("v2").offset(i)

If Worksheets(speciality).Range("v2").offset(i) <> "" Then
Worksheets("MAP1").Range("i12").offset(k).Interior.ColorIndex = color_comments
End If



'id row
'its just a additionnal way to identify the activity, it will help to avoid mistakes
Worksheets("MAP1").Range("r12").offset(k) = i + 2



'ecriture des charges en fonction des dates
'debut en AP



'check if the activity is in the right time
If activity_realend - date_begin > 0 Then
For j = 0 To activity_realend - activity_begin
If activity_begin - date_begin + j > 0 Then
Worksheets("MAP1").Range("r12").offset(k, activity_begin - date_begin + j + added_columns) = Worksheets(speciality).Range("ap2").offset(i, j * 3)
Worksheets("MAP1").Range("r12").offset(k, activity_begin - date_begin + j + added_columns).Interior.ColorIndex = color_late
If j <= activity_end - activity_begin Then
Worksheets("MAP1").Range("r12").offset(k, activity_begin - date_begin + j + added_columns).Interior.ColorIndex = color_running
End If
End If
Next j
End If
k = k + 1


End If
End If

i = i + 1
Wend


n = n + 1
Wend
'Next n
MsgBox ("Reading OK")
Application.ScreenUpdating = True



ActiveSheet.Columns("p:p").offset(0, added_columns).WrapText = False
'put some lines on the current CW
Dim cw_until_today As Double
cw_until_today = cw_to_int(Worksheets("MAP1").Range("f4").Value) - cw_to_int(Worksheets("MAP1").Range("e3").Value)

Worksheets("MAP1").Range(Cells(12, 20 + cw_until_today), Cells(12 + k, 20 + cw_until_today)).Borders(xlEdgeLeft).Weight = xlMedium
Worksheets("MAP1").Range(Cells(12, 20 + cw_until_today), Cells(12 + k, 20 + cw_until_today)).Borders(xlEdgeRight).Weight = xlMedium
Worksheets("MAP1").Cells(10, 21 + cw_until_today).Interior.ColorIndex = color_currentcw
Worksheets("MAP1").Cells(11, 21 + cw_until_today).Interior.ColorIndex = color_currentcw

End Sub
 
Trier par date Trier par votes
Robert

Robert

XLDnaute Barbatruc
Repose en paix
Bonjour Bil, bonjour le forum,

Ta macro est bien trop longue pour donner à quiconque envie d'y regarder de plus près !...
Travailler sur plusieurs onglets ou sur plusieurs classeurs est basiquement la même chose si on spécifie systématiquement les noms ClasseurSource/OngletSource et ClassseurDestination/OngletDestination. Copier la cellule A1 de l'onglet Test du Classeur Source1.xlsx et la coller dans la cellule A1 de l'onglet Base du Classeur Final.xlsm avec les deux classeurs ouverts s'écrira :
VB: 
Workbooks("Source1.xlsx").Worksheets("test").Range("A1").Copy Workbooks("Final.xlsm").Worksheets("Base").Range("A1")


J'utilise le genre de code ci-dessous pour copier les données de tous les classeurs source (xlsx) se trouvant dans le même dossier que le classeur destination. La macro se trouve dans le classeur du classeur destination (xlsm) :
Code: 
Sub Macro1()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim F As String 'déclare la variable F (Fichier)

Set CD = ThisWorkbook 'définit le classeur destination CD (à adapter)
Set OD = CD.Worksheets("le_Nom_de_l_onglet_Destination") 'définit l'onglet destination OD (à adapter)
CA = CD.Path & "\" 'définit le chemin d'accès CA
F = Dir(CA & "*.xlsx") 'définit le premier fichier xlsx (à adapter) ayant CA comme chemin d'accès (à adapter)
Do While F <> "" 'boucle tant qu'il existe des fichiers
    If Not F = CD.Name Then 'condition : si F n'est pas le fichier destination
        Set CS = Application.Workbooks.Open(CA & F) 'définit le classeur source (en l'ouvrant)
        Set OS = CS.Worksheets("le_Nom_de_l_onglet_Destination") 'définit l'onglet source OS (à adapter)
       
        '***********************************'
        'ici tu récupères les données de l'onglet source vers l'onglet destination avec un code du style
        'OD.range("A1").value=OS.range("A1").value ou
        'OS.range("A1").copy OD.range("A1").Value ou
        'etc
        '***********************************'
        CS.Close False 'ferme le classeur source sans enregistrer
        F = Dir 'définit le prochain fichier xlsx ayant CA comme chemin d'accès
    End If 'fin de la condition
Loop 'boucle
End Sub

Peut-être ça pourra t'aider...
 
Dernière édition:
Vote positif 0 Vote négatif
B

BIL boud

XLDnaute Occasionnel
Robert à dit:
Bonjour Bil, bonjour le forum,

Ta macro est bien trop longue pour donné à quiconque envie d'y regarder de plus près !...
Travailler sur plusieurs onglets ou sur plusieurs classeurs est basiquement la même chose si on spécifie systématiquement les noms ClasseurSource/OngletSource et ClassseurDestination/OngletDestination. Copier la cellule A1 de l'onglet Test du Classeur Source1.xlsx et la coller dans la cellule A1 de l'onglet Base du Classeur Final.xlsm avec les deux classeurs ouverts s'écrira :
VB: 
Workbooks("Source1.xlsx").Worksheets("test").Range("A1").Copy Workbooks("Final.xlsm").Worksheets("Base").Range("A1")


J'utilise le genre de code ci-dessous pour copier les données de tous les classeurs source (xlsx) se trouvant dans le même dossier que le classeur destination. La macro se trouve dans le classeur du classeur destination (xlsm) :
Code: 
Sub Macro1()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim F As String 'déclare la variable F (Fichier)

Set CD = ThisWorkbook 'définit le classeur destination CD (à adapter)
Set OD = CD.Worksheets("le_Nom_de_l_onglet_Destination") 'définit l'onglet destination OD (à adapter)
CA = CD.Path & "\" 'définit le chemin d'accès CA
F = Dir(CA & "*.xlsx") 'définit le premier fichier xlsx (à adapter) ayant CA comme chemin d'accès (à adapter)
Do While F <> "" 'boucle tant qu'il existe des fichiers
    If Not F = CD.Name Then 'condition : si F n'est pas le fichier destination
        Set CS = Application.Workbooks.Open(CA & F) 'définit le classeur source (en l'ouvrant)
        Set OS = CS.Worksheets("le_Nom_de_l_onglet_Destination") 'définit l'onglet source OS (à adapter)
       
        '***********************************'
        'ici tu récupères les données de l'onglet source vers l'onglet destination avec un code du style
        'OD.range("A1").value=OS.range("A1").value ou
        'OS.range("A1").copy OD.range("A1").Value ou
        'etc
        '***********************************'
        CS.Close False 'ferme le classeur source sans enregistrer
        F = Dir 'définit le prochain fichier xlsx ayant CA comme chemin d'accès
    End If 'fin de la condition
Loop 'boucle
End Sub

Peut-être ça pourra t'aider...
Cliquez pour agrandir...
bonjour

oui c vrai vous avez raison le code est vraiment long
merci pour votre reponse
 
Vote positif 0 Vote négatif

Discussions similaires

T
  • Question
XL 2016 Optimisation d'une boucle
2 3
Réponses
30
Affichages
896
thivame
T
M
  • Résolu(e)
XL 2016 Amélioration de code
Réponses
3
Affichages
344
M@xu3L
M
S
  • Question
XL 2016 VBA EXCEL
Réponses
2
Affichages
311
simon-baril01
S
FRYS
  • Question
Microsoft 365 Retrouver les dépendants de cellules nommées
Réponses
6
Affichages
202
crocrocro
C
L
  • Question
XL 2021 Comment utiliser la colonne d'une adresse en Private Sub - svp ?
Réponses
3
Affichages
254
vgendron
vgendron
D
  • Question
XL 2021 VBA - Erreur 1004 aléatoire - Image/Logo
Réponses
10
Affichages
349
crocrocro
C
J
  • Question
XL 2016 Listbox et valeur associée
2
Réponses
16
Affichages
760
jozerebel
J
halecs93
  • Résolu(e)
XL 2016 Indice n'appartient pas à la sélection : HELP !!!!
2
Réponses
21
Affichages
526
halecs93
halecs93
C
  • Question
XL 2019 Déplacer lignes selon contenu d'une cellule
Réponses
2
Affichages
763
ARMAEL
A
E
  • Question
XL 2013 vba excel
Réponses
6
Affichages
230
sylvanu
sylvanu

Membres actuellement en ligne

16 membres et 126 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 113
Messages
2 085 426
Membres
102 887
dernier inscrit
MarcVeretz