Discussion :

[crupa]

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 :

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

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
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