Bonjour Team,
J'espère que vous allez bien!
J'ai un problème au niveau des affectations d'un fichier A à un fichier B à partir d'un fichier C dans lequel est écrit mon code VBA;
En effet, dans C , il y'a un bouton qu'on click et ca part prendre au fur et à mesure des valeurs dans A et par les comparées à celle dans B;
quant elle trouve une correspondance, elle copie certaines données de cette ligne et va la copier dans A sur la ligne correspondante(cellule après cellule).
L'action s'effectue bien, le code gère bien la fermeture des fichiers; mais quant j'ouvre bien après mon fichier A pour vérifier la copie des données, le fichier n'affiche rien (ni de colonne, ni de cellule, et souvent il est accompagné d'une alerte "Avis de sécurité Microsoft Excel" que j'active mais sans retour favorable malgré cela). Voir pièce jointe
Esquisse du code : J'ai créer 02 modules à cet effet (Merci d'avance )
Module 1 :
Module 2 :
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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 Option Explicit Public iCel, indexCel, RowFm, RowBal, Plage, Nb, Row_Bal As Long Public CelBal, CelFm, colonne, NowFm, NowBal, recept_plage, PointFm, PointBal, cptBal_1, cptBal_2 As String Public FichE1, FichE2 As Workbook Public ws, ws2 As Worksheet Public la_date As Date Sub affectation() Dim NumEuroLine, NumTrackLine As Long RowFm = "5" RowBal = "4" Call Module1.ExtraVal(RowFm, RowBal) End Sub Public Sub OpenCnx() Set FichE1 = GetObject("D:\SESAME\8\balance.xlsx") Set ws = FichE1.Sheets(1) Set FichE2 = GetObject("D:\SESAME\8\FM1000.xlsx") Set ws2 = FichE2.Sheets(1) End Sub Function ExtraVal(ByVal AdressFm As String, ByVal AdressBal As String) Call OpenCnx PointFm = "A" & AdressFm NowFm = ws2.Range(PointFm).Value 'Worksheets("FM1000").Range(PointFm).Value Call EuroLine(CInt(AdressBal)) If Nb = 0 Then MsgBox "Aucune ligne affectée !! ", vbInformation, "ADVANS Cameroun" Else FichE1.Close FichE2.SaveCopyAs "D:\FM10000.xls" 'ActiveWorkbook.Save FichE2.Close SaveChanges:=True MsgBox "Nombre de ligne(s) inscrite(s) : " & Nb, vbInformation, "ADVANS Cameroun" End If End Function Public Sub EuroLine(NumT As Long) Nb = 0 Row_Bal = "4" cptBal_1 = "A" & NumT cptBal_2 = ws.Range(cptBal_1).Value Do Until (cptBal_2 = "") Row_Bal = Row_Bal + 1 PointBal = "A" & Row_Bal cptBal_2 = ws.Range(PointBal).Value Loop Do Until (NowFm = "") For Plage = NumT To Row_Bal recept_plage = "A" & Plage NowBal = ws.Range(recept_plage).Value If StrComp(Trim(NowFm), Trim(NowBal)) = 0 Then Nb = Nb + 1 RowBal = Plage Call importer(1, 6) Exit For End If Next Plage RowFm = RowFm + 1 PointFm = "A" & RowFm NowFm = ws2.Range(PointFm).Value Loop End Sub
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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 Public Sub importer(x As Integer, y As Integer) Application.ScreenUpdating = False Application.DisplayAlerts = False Application.Calculation = xlCalculationManual Application.ReferenceStyle = xlA1 Call OpenCnx For iCel = x To y Call CrossLine ws.Range(CelBal).Copy ws2.Activate 'Application.Workbooks("FM1000.xlsx").Worksheets("FM1000").Activate ws2.Range(CelFm).Select ActiveSheet.PasteSpecial 'Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ 'False, Transpose:=False 'MsgBox "Coller : " & ws2.Range(CelFm).Value 'Exit For Next iCel Application.ScreenUpdating = True Application.DisplayAlerts = True Application.Calculation = xlCalculationAutomatic End Sub Public Sub CrossLine() Select Case iCel Case 1 CelBal = "C" & RowBal CelFm = "C" & RowFm Case 2 CelBal = "D" & RowBal CelFm = "E" & RowFm Case 3 CelBal = "F" & RowBal CelFm = "E" & RowFm Case 4 CelBal = "G" & RowBal CelFm = "F" & RowFm Case 5 CelBal = "H" & RowBal CelFm = "G" & RowFm Case 6 CelBal = "G" & RowBal CelFm = "H" & RowFm End Select End Sub
Partager