Modifier du code vb dans excel par macro
Résolu
tournevice
Messages postés
10
Date d'inscription
lundi 27 février 2006
Statut
Membre
Dernière intervention
26 décembre 2006
-
6 juil. 2006 à 12:06
tournevice Messages postés 10 Date d'inscription lundi 27 février 2006 Statut Membre Dernière intervention 26 décembre 2006 - 17 juil. 2006 à 16:12
tournevice Messages postés 10 Date d'inscription lundi 27 février 2006 Statut Membre Dernière intervention 26 décembre 2006 - 17 juil. 2006 à 16:12
A voir également:
- Modifier du code vb dans excel par macro
- Tous les codes vba excel - Conseils pratiques -Visual Basic / VB.NET
- Désactiver macro excel ✓ - Forum VB.NET
- Copier macro excel - Forum VBA Office (Excel, Word ...)
- Vb vba ✓ - Forum VB.NET
- Arctan excel - Forum Visual Basic
2 réponses
tournevice
Messages postés
10
Date d'inscription
lundi 27 février 2006
Statut
Membre
Dernière intervention
26 décembre 2006
17 juil. 2006 à 16:12
17 juil. 2006 à 16:12
a partir de ce que j'ai trouvé sur le forum j'ai trouvé une solution à mon pb :
Function sChangeCaractere(ByVal laChaine As String, ByVal old_car As String, ByVal new_car As String) As String
Dim ncar As Integer, lng As Integer, result As String, txt As String
lng = Len(old_car)
txt = laChaine
If lng <= 0 Then
sChangeCaractere = txt
Exit Function
End If
On Error GoTo ErrChangeCaractre
If lng <= 0 Or Len(Trim(txt)) <= 0 Then
sChangeCaractere = txt
Exit Function
End If
result = vbNullString
ncar = InStr(txt, old_car)
Do While ncar
If Len(result) > 0 Then
If lng > 1 Then
If ncar = 1 Then
result = result & new_car
Else
result = result & Left(txt, ncar - 1) & new_car
End If
Else
result = result & Left(txt, ncar - 1) & new_car
End If
Else
result = Left(txt, ncar - 1) & new_car
End If
If lng > 1 Then
txt = Right(txt, Len(txt) - ncar - (lng - 1))
Else
txt = Right(txt, Len(txt) - ncar)
End If
ncar = InStr(txt, old_car)
Loop
If Len(txt) > 0 Then result = result & txt
sChangeCaractere = result
Exit Function
ErrChangeCaractre:
sChangeCaractere = result
End Function
Sub parcours_arborescence()
disque = "C"
chemin = "c:\temp\toto"
Set fs = Application.FileSearch
Set fso = CreateObject("Scripting.FileSystemObject")
With fs
.LookIn = chemin
.SearchSubFolders = True
.Filename = "*.xls"
If .Execute() > 0 Then
MsgBox "There were " & .FoundFiles.Count & _
" file(s) found."
For i = 1 To .FoundFiles.Count
Set fic = fso.GetAbsoluteFileName(.FoundFiles(i))
'MsgBox fso.GetAbsolutePathName(.FoundFiles(i))
Next i
Else
MsgBox "There were no files found."
End If
End With
End Sub
Sub traite_tous_les_fichier_d_un_dossier()
disque = "C"
chemin = "c:\temp\toto"
fichier_log = chemin & "resultat.log"
chemin_origine = "T:\toto\tata\titi"
chemin_nouveau = "c:\temp"
ChDrive (disque)
ChDir (chemin)
Set FSys = CreateObject("Scripting.FileSystemObject")
FSys.DeleteFile (fichier_log)
Set MonFic = FSys.CreateTextFile(fichier_log, False)
If Err.Number = 0 Then
MonFic.writeLine "Fichiers non traites"
Else
FSys.DeleteFile (fichier_log)
Set MonFic = FSys.CreateTextFile(fichier_log, False)
MonFic.writeLine "Fichiers non traites"
End If
With Application.FileSearch
Dim fichier_fait As Boolean
Dim cpt_fait As Long
Dim cpt_total As Long
Dim fic As String
cpt_fait = 0
'.NewSearch
.LookIn = chemin
.SearchSubFolders = True
'.FileType = msoFileTypeExcelWorkbooks
.Filename = "*.xls"
If .Execute > 0 Then
MsgBox "There were " & .FoundFiles.Count & _
" file(s) found."
cpt_total = .FoundFiles.Count
For i = 1 To .FoundFiles.Count
fic = .FoundFiles(i)
fichier_fait = False
Dim strold As String
Dim c_Wks As Workbook
Set c_Wks = Workbooks.Open(.FoundFiles(i))
'MsgBox c_Wks.Name
For j = 1 To Modules.Count
With c_Wks.VBProject.VBComponents.Item(j).CodeModule
Dim cmpt As Long
cmpt = .CountOfLines
Dim c_start As Long
Dim b As Boolean
Dim x As Long
x = 1
b = .Find(chemin_origine, x, 1, -1, -1)
If b = True Then
Dim temp As String
temp = .Lines(x, 1)
Dim s_temp As String
s_temp = sChangeCaractere(temp, chemin_origine, chemin_nouveau)
.ReplaceLine x, s_temp
fichier_fait = True
cpt_fait = cpt_fait + 1
End If
End With
Next j
If Not fichier_fait Then
'fic = CStr(FSys.GetAbsoluteFileName(.FoundFiles(i)))
MonFic.writeLine (FSys.GetAbsolutePathName(.FoundFiles(i)))
'MsgBox FSys.GetAbsolutePathName(.FoundFiles(i))
End If
c_Wks.Save
c_Wks.Close
'.FoundFiles.Item(i).Close
Next i
Else
MsgBox "Aucun fichier n'a été trouvé."
End If
End With
MonFic.Close
End Sub
Function sChangeCaractere(ByVal laChaine As String, ByVal old_car As String, ByVal new_car As String) As String
Dim ncar As Integer, lng As Integer, result As String, txt As String
lng = Len(old_car)
txt = laChaine
If lng <= 0 Then
sChangeCaractere = txt
Exit Function
End If
On Error GoTo ErrChangeCaractre
If lng <= 0 Or Len(Trim(txt)) <= 0 Then
sChangeCaractere = txt
Exit Function
End If
result = vbNullString
ncar = InStr(txt, old_car)
Do While ncar
If Len(result) > 0 Then
If lng > 1 Then
If ncar = 1 Then
result = result & new_car
Else
result = result & Left(txt, ncar - 1) & new_car
End If
Else
result = result & Left(txt, ncar - 1) & new_car
End If
Else
result = Left(txt, ncar - 1) & new_car
End If
If lng > 1 Then
txt = Right(txt, Len(txt) - ncar - (lng - 1))
Else
txt = Right(txt, Len(txt) - ncar)
End If
ncar = InStr(txt, old_car)
Loop
If Len(txt) > 0 Then result = result & txt
sChangeCaractere = result
Exit Function
ErrChangeCaractre:
sChangeCaractere = result
End Function
Sub parcours_arborescence()
disque = "C"
chemin = "c:\temp\toto"
Set fs = Application.FileSearch
Set fso = CreateObject("Scripting.FileSystemObject")
With fs
.LookIn = chemin
.SearchSubFolders = True
.Filename = "*.xls"
If .Execute() > 0 Then
MsgBox "There were " & .FoundFiles.Count & _
" file(s) found."
For i = 1 To .FoundFiles.Count
Set fic = fso.GetAbsoluteFileName(.FoundFiles(i))
'MsgBox fso.GetAbsolutePathName(.FoundFiles(i))
Next i
Else
MsgBox "There were no files found."
End If
End With
End Sub
Sub traite_tous_les_fichier_d_un_dossier()
disque = "C"
chemin = "c:\temp\toto"
fichier_log = chemin & "resultat.log"
chemin_origine = "T:\toto\tata\titi"
chemin_nouveau = "c:\temp"
ChDrive (disque)
ChDir (chemin)
Set FSys = CreateObject("Scripting.FileSystemObject")
FSys.DeleteFile (fichier_log)
Set MonFic = FSys.CreateTextFile(fichier_log, False)
If Err.Number = 0 Then
MonFic.writeLine "Fichiers non traites"
Else
FSys.DeleteFile (fichier_log)
Set MonFic = FSys.CreateTextFile(fichier_log, False)
MonFic.writeLine "Fichiers non traites"
End If
With Application.FileSearch
Dim fichier_fait As Boolean
Dim cpt_fait As Long
Dim cpt_total As Long
Dim fic As String
cpt_fait = 0
'.NewSearch
.LookIn = chemin
.SearchSubFolders = True
'.FileType = msoFileTypeExcelWorkbooks
.Filename = "*.xls"
If .Execute > 0 Then
MsgBox "There were " & .FoundFiles.Count & _
" file(s) found."
cpt_total = .FoundFiles.Count
For i = 1 To .FoundFiles.Count
fic = .FoundFiles(i)
fichier_fait = False
Dim strold As String
Dim c_Wks As Workbook
Set c_Wks = Workbooks.Open(.FoundFiles(i))
'MsgBox c_Wks.Name
For j = 1 To Modules.Count
With c_Wks.VBProject.VBComponents.Item(j).CodeModule
Dim cmpt As Long
cmpt = .CountOfLines
Dim c_start As Long
Dim b As Boolean
Dim x As Long
x = 1
b = .Find(chemin_origine, x, 1, -1, -1)
If b = True Then
Dim temp As String
temp = .Lines(x, 1)
Dim s_temp As String
s_temp = sChangeCaractere(temp, chemin_origine, chemin_nouveau)
.ReplaceLine x, s_temp
fichier_fait = True
cpt_fait = cpt_fait + 1
End If
End With
Next j
If Not fichier_fait Then
'fic = CStr(FSys.GetAbsoluteFileName(.FoundFiles(i)))
MonFic.writeLine (FSys.GetAbsolutePathName(.FoundFiles(i)))
'MsgBox FSys.GetAbsolutePathName(.FoundFiles(i))
End If
c_Wks.Save
c_Wks.Close
'.FoundFiles.Item(i).Close
Next i
Else
MsgBox "Aucun fichier n'a été trouvé."
End If
End With
MonFic.Close
End Sub
valtrase
Messages postés
937
Date d'inscription
lundi 19 janvier 2004
Statut
Membre
Dernière intervention
9 mai 2022
3
7 juil. 2006 à 01:02
7 juil. 2006 à 01:02
Salut,
Voilà un code qui te sera utile
' c_Wks Le classeur qui contient la macro
' MyMacro Le nom de la macro
' c_Mod Le nom du module
' Ligne la première ligne de la macro à modifier
' c_Change Le nouveau code sous la forme
' Ex: dans la Macro appelante' c_Change " For i 1 to 100"' c_Change c_Change & vbCrLf & " Listbox1 "Fichier & i"
' c_Change = c_Change & vbCrLf & " Next"
Sub ChangeMacro( _
c_Wks As Workbook, _
MyMacro As String, _
c_Mod As String, _
Ligne As Long, _
c_Change As String _
)
Dim c_Start As Long
' On va travailler avec le code
With c_Wks.VBProject.VBComponents(c_Mod).CodeModule
' on recherche la position de la première ligne de la macro
Start = .ProcBodyLine(MyMacro, 0)
' on suprime un nombre de ligne
.DeleteLines Start + Ligne, 1
' Et on insère notre code contenu dans c_change
.InsertLines Start + Ligne, c_Change
End With
End Sub
Cordialement, Jean-Paul
______________________________________________________________________
Le Savoir n'a de valeur que s'il est partagé
Voilà un code qui te sera utile
' c_Wks Le classeur qui contient la macro
' MyMacro Le nom de la macro
' c_Mod Le nom du module
' Ligne la première ligne de la macro à modifier
' c_Change Le nouveau code sous la forme
' Ex: dans la Macro appelante' c_Change " For i 1 to 100"' c_Change c_Change & vbCrLf & " Listbox1 "Fichier & i"
' c_Change = c_Change & vbCrLf & " Next"
Sub ChangeMacro( _
c_Wks As Workbook, _
MyMacro As String, _
c_Mod As String, _
Ligne As Long, _
c_Change As String _
)
Dim c_Start As Long
' On va travailler avec le code
With c_Wks.VBProject.VBComponents(c_Mod).CodeModule
' on recherche la position de la première ligne de la macro
Start = .ProcBodyLine(MyMacro, 0)
' on suprime un nombre de ligne
.DeleteLines Start + Ligne, 1
' Et on insère notre code contenu dans c_change
.InsertLines Start + Ligne, c_Change
End With
End Sub
Cordialement, Jean-Paul
______________________________________________________________________
Le Savoir n'a de valeur que s'il est partagé