VBA EXCEL Problème de lien apres la copie d'une feuille
Kimphat
Messages postés5Date d'inscriptionmercredi 9 juillet 2008StatutMembreDernière intervention11 juillet 2008
-
9 juil. 2008 à 20:05
Kimphat
Messages postés5Date d'inscriptionmercredi 9 juillet 2008StatutMembreDernière intervention11 juillet 2008
-
9 juil. 2008 à 20:06
Bonjour,
J'ai fait une form, qui est attaché à un workbook, qui prends des informations. Par la suite du workbook original (WbOriginal) je créé un nouveau workbook (Wb). Je copie les feuilles avec les nouveaux paramètre dans acquis dans la form. Mon problème est que dans WbOriginal j'ai une feuille avec des listbox qui on comme référence un groupe de cellule nommé. Lorsque je copie la feuille dans Wb les listbox garde la référence du groupe de cellule nommé dans WbOriginal même si j'ai le même groupe de cellule nommé dans le Wb.
Voici le code complet ci-dessous. Bonne chance au coeur sensible pcq tout est dans le boutton
Private Sub Button1_Click()
Dim x As Integer
Dim y As Integer
Dim LigneACopier As Integer
Dim DefaultLoopsNumber As Integer
Dim DefaultSheetNumberInBook As Long
Dim Wb As Workbook
Dim WbOriginal As Workbook
Dim NomDuFichier As String
Dim FormuleImpedance As String
Dim CelluleCourante As Range
Dim PlageCourante As Range
'Empèche les update dans l'écran
Application.ScreenUpdating = False
Set WbOriginal = ActiveWorkbook
DefaultSheetNumberInBook = 1
DefaultLoopsNumber = 3
If NomDeLaFerme_TB.Value = "" Then
NomDeLaFerme_TB.Value = "john Doe"
End If
'Test si la valeur n'est pas vide
If NombreDeLoop_TB.Value = "" Then
NombreDeLoop_TB.Value = DefaultLoopsNumber
End If
'Initialisation de variable pour la création du nouveau workbook
TodayDate = Format(Now(), "dd-mm-yy")
TodayDateMFisrt = Format(Now(), "mm-dd-yyyy")
chemin = ActiveWorkbook.Path
NomDuFichier = chemin & "" & NomDeLaFerme_TB.Value & "_" & TodayDate & ".xls"
'minimise le nombre de feuille
Application.SheetsInNewWorkbook = DefaultSheetNumberInBook
'Création du nouveau workbook
Set Wb = Workbooks.Add
Application.DisplayAlerts = False
Wb.SaveAs (NomDuFichier)
Application.DisplayAlerts = True
'Copy de la table Data sheet(1)
WbOriginal.Sheets("Data").Copy before:=Wb.Sheets(1)
'Copy de la table Z Neu Table sheet(2)
WbOriginal.Sheets("Z Neu table").Copy after:=Wb.Sheets(1)
'Copy de la table Layout sheet(3)
WbOriginal.Sheets("Layout").Copy after:=Wb.Sheets(2)
'Copy de la table Data Logger sheet(4)
WbOriginal.Sheets("Data Logger").Copy after:=Wb.Sheets(3)
'Copy de la table Loops sheet(5)
WbOriginal.Sheets("Loops").Copy after:=Wb.Sheets(4)
'Rename la sheet("Loops")
Wb.Sheets(5).Name = NombreDeLoop_TB.Value & " Loops"
'efface la feuille par défaut dans le workbook
' On Error Resume Next
Application.DisplayAlerts = False
Wb.Sheets(6).Delete
Application.DisplayAlerts = True
'Remplis les renseignements sur la feuille Z Neu Table
Wb.Sheets("Z Neu table").Select
Set CelluleCourante = Range("FarmName")
CelluleCourante.Value = NomDeLaFerme_TB.Text
Set CelluleCourante = Range("NuvoltUserName")
CelluleCourante.Value = NuvoltEmpListBox.Value
Set CelluleCourante = Range("ZneutableDate")
CelluleCourante.Value = TodayDateMFisrt
'reprogramme les cellules pour avoir les mêmes valeurs partout
For x = 1 To 3
For y = 1 To 3
Wb.Sheets(2 + x).Select
Set CelluleCourante = Range("F" & y + 1)
CelluleCourante.Formula = "='Z Neu table'!I" & y + 1
Next y
Next x
'Création de la table Z Neutre
Wb.Sheets("Z Neu table").Select
'Boucle de copie des lignes dans la feuille loops
For LigneACopier = 1 To ((NombreDeLoop_TB.Value - DefaultLoopsNumber))
'ligne à copier dans la section formule
Rows(13 + LigneACopier).Select
Selection.Insert Shift = xlDown
CutCopyMode = False
Rows(Selection.Row - 1).Copy
Rows(Selection.Row).Select
ActiveSheet.Paste
'renommer les cellules
Set CelluleCourante = Range("C" & LigneACopier + 13)
CelluleCourante.Formula = "Loop " & LigneACopier + DefaultLoopsNumber
Next LigneACopier
'Création de la table Loop
Wb.Sheets(NombreDeLoop_TB.Value & " Loops").Select
'Boucle de copie des lignes dans la feuille loops
For LigneACopier = 1 To ((NombreDeLoop_TB.Value - DefaultLoopsNumber))
'ligne à copier dans la section formule
Rows(11 + LigneACopier).Select
Selection.Insert Shift = xlDown
CutCopyMode = False
Rows(Selection.Row - 1).Copy
Rows(Selection.Row).Select
ActiveSheet.Paste
'renommer les cellules
Set CelluleCourante = Range("C" & LigneACopier + 11) CelluleCourante.Formula "Ztot Loop " & LigneACopier + DefaultLoopsNumber & ""
Set CelluleCourante = Range("E" & LigneACopier + 11) CelluleCourante.Formula "Zneu Loop " & LigneACopier + DefaultLoopsNumber & ""
'ligne à copier dans la section identification
'17 ligne de départ + 2 * ligner à copier = incérmentation de la boucle + les lignes qui s'ajoutes à l'étape avant
Rows(17 + 2 * LigneACopier).Select
Selection.Insert Shift = xlDown
CutCopyMode = False
Rows(Selection.Row - 1).Copy
Rows(Selection.Row).Select
ActiveSheet.Paste
'renommer la cellule d'identification
Set CelluleCourante = Range("C" & 17 + 2 * LigneACopier)
CelluleCourante.Formula = "Loop " & LigneACopier + DefaultLoopsNumber
CutCopyMode = False
Next LigneACopier
'Création des formules d'impédance
'Faire toutes les loops
For x = 1 To NombreDeLoop_TB.Value
'S'assure que la formule est vide
FormuleImpedance = "=F" & 8 + x & " + H" & 8 + x & "+(1/("
'créé la formule FormuleImpedance. Le nombre de membre de la formule = le nombre de loop
For y = 1 To NombreDeLoop_TB.Value
If y <> x Then
FormuleImpedance = FormuleImpedance & "(1/(F" & 8 + y & " + H" & 8 + y & "))"
If y <> NombreDeLoop_TB.Value Then
FormuleImpedance = FormuleImpedance & "+"
End If
End If
Next y
'Lors de l'écriture de la dernière ligne le + reste présent à cause du if y <> x
If x = NombreDeLoop_TB.Value Then
FormuleImpedance = Left(FormuleImpedance, Len(FormuleImpedance) - 1) 'efface le +
End If
'ferme la formule
FormuleImpedance = FormuleImpedance & "))"
'choisie la cellule ou écrire
Set CelluleCourante = Range("B" & 8 + x)
'écrit la formule dans la cellule
CelluleCourante.Formula = FormuleImpedance
'Fais le lien entre la table d'impédance des neutres et celle des loops
Set CelluleCourante = Range("F" & 8 + x)
CelluleCourante.Formula = "='Z Neu table'!S" & 10 + x
Next x
Wb.Sheets("Z Neu table").Select
Application.ScreenUpdating = True
Wb.Save
Wb.Activate
WbOriginal.Save
UserForm1.Hide
End Sub
A voir également:
VBA EXCEL Problème de lien apres la copie d'une feuille
