Execution macro excel

Question

Bonjour a tous, 
Depuis quelques temps je fais face aune difficulte a laquelle je ne trouve pas de solution. 
En effet j ai realise une macro pour le traitement des donnes contenu ds des fichier csv et txt. 
l'execution de la macro initialement prenait 6 mn et sans que je ne comprenne pourquoi le temps d execution est devenu de plus en plus long avec parfois des echecs d'execution. 
Maintenant la macro prend au mois 20 mn pour s execute et ds ce cas je ne doit rien faire d autre sur la machine meme ouvrir un autre fichier dossier ou application car la macro va se plante et va me donner l erreur suivante : 
run-time-error '-2147417848(80010108)' 
Method 'Replace' of object 'Range' Failed. 

Cette macro marche bien sur les autres PC sauf le mien, 
au debut j'ai meme du acheter un nouveau PC car l ancien etait tres vieux et je croyais que cela pouvait etre la cause. 

Est ce que quelqu'un peut m aider a comprendre de ce qui ne va pas et comment resoudre ce problem. 

Merci d'avance.

userrrqi115 · Answer

Hello, 

Que fais cette macro exactement ? un peu de code STP.
BR

USERRRQI115
Simple user
Great brain

cs_bambival · Answer

voila le code: Sub Bouton1_Clic() 'Outils de génération de donnés pour fichier cel, Piano et TRF2002 'Conçu le 16 Aôut 2008 oldStatusBar = Application.DisplayStatusBar Application.DisplayStatusBar = True Application.ScreenUpdating = True Application.Calculation = xlCalculationManual 'Application.Calculation = xlCalculationAutomatic Application.SheetsInNewWorkbook = 9 Dim NumOMC As Integer, LigneDebut As Integer, I As Integer Dim TABRow(6) As Integer Do I = I + 1 If I = 2 Then Exit Sub NumOMC = Application.InputBox("Enter the Number of OMCs, Max 5", Type:=1, Title:="RF Data Generator") Loop While NumOMC > 5 Or NumOMC < 1 'Ouverture de fichier MrxCell = 0 MrxExtO = 0 Mrxadja = 0 MrxBSC = 0 MrxMoto = 0 Mrxfield = 0 Mrxtrav = 1 Dim TabFolderName(5) As String, TabFileName(5) As String 'recuperation des chemins Set fd = Application.FileDialog(msoFileDialogFolderPicker) With fd If .Show = -1 Then TabFolderName(1) = .SelectedItems(1) Else Exit Sub End If End With TabFileName(1) = TabFolderName(1) & "\EGPRS1" TabFileName(2) = TabFolderName(1) & "\eomc3" TabFileName(3) = TabFolderName(1) & "\eomc4" TabFileName(4) = TabFolderName(1) & "\eomc5" TabFileName(5) = TabFolderName(1) & "\eomc6" For j = 1 To NumOMC Application.ScreenUpdating = False ' Creation espace de travail If j = 1 Then Workbooks.Add Traitement = ActiveWorkbook.Name With Workbooks(Traitement) .Worksheets(1).Name = "CellData" .Worksheets(2).Name = "AdjacencyData" .Worksheets(3).Name = "ExternalOMCData" .Worksheets(4).Name = "MotoData" .Worksheets(5).Name = "FieldData" .Worksheets(6).Name = "Travail" .Worksheets(7).Name = "FichierCel" .Worksheets(8).Name = "Piano" .Worksheets(9).Name = "TRF2000" End With End If 'Ouverture du fichier Cell fichierCELL = TabFileName(j) & "\Cell.csv" Application.StatusBar = "Opening " & fichierCELL Workbooks.OpenText Filename:=fichierCELL, local:=True CellsData = ActiveWorkbook.Name 'Copie des données Range("B2:B5000, ET2:ET5000, EW2:EW5000, FE2:FE5000, FF2:FF5000, FI2:FI5000, JV2:JV5000, LJ2:LJ5000").Copy 'Collage des données Workbooks(Traitement).Activate Worksheets("CellData").Activate Worksheets("CellData").Paste Destination:=Range("A1") MrxCell = Cells(5000, 1).End(xlUp).Row 'Fermeture du fichier Application.CutCopyMode = False Workbooks(CellsData).Close SaveChanges:=False 'Ouverture ExternalOMC fichierExtOMC = TabFileName(j) & "\ExternalOmcCell.csv" 'Ouverture du fichier Application.StatusBar = "Opening " & fichierExtOMC Workbooks.OpenText Filename:=fichierExtOMC, local:=True ExtOMCData = ActiveWorkbook.Name 'Copie des donnees Range("B2:B5000, R2:R5000").Copy 'Collage des données Workbooks(Traitement).Activate Worksheets("ExternalOMCData").Activate Worksheets("ExternalOMCData").Paste Destination:=Range("A1") MrxExtO = Cells(2000, 1).End(xlUp).Row 'Ajout CellReff et CI dans les données cells pour le traitement des HO Range("A2:A" & MrxExtO).Copy Destination:=Worksheets("CellData").Range("A" & MrxCell + 1) Range("B2:B" & MrxExtO).Copy Destination:=Worksheets("CellData").Range("F" & MrxCell + 1) 'Fermeture du fichier Application.CutCopyMode = False Workbooks(ExtOMCData).Close SaveChanges:=False 'Ouverture Adjacency fichierAdja = TabFileName(j) & "\Adjacency.csv" 'Ouverture du fichier Application.StatusBar = "Opening " & fichierAdja Workbooks.OpenText Filename:=fichierAdja, local:=True AdjaData = ActiveWorkbook.Name 'Copie des donnees Range("B2:B150000").Copy 'Collage des données Workbooks(Traitement).Activate Worksheets("AdjacencyData").Activate Worksheets("AdjacencyData").Paste Destination:=Range("A1") Mrxadja = Cells(150000, 1).End(xlUp).Row 'Fermeture du fichier Application.CutCopyMode = False Workbooks(AdjaData).Close SaveChanges:=False 'BSC Data 'Ouverture Adjacency fichierBSC = TabFileName(j) & "\RnlAlcatelBSC.csv" 'Ouverture du fichier Application.StatusBar = "Opening " & fichierBSC Workbooks.OpenText Filename:=fichierBSC, local:=True BSCData = ActiveWorkbook.Name 'Copie des donnees Range("B2:B1000,MX2:MX1000").Copy 'Collage des données Workbooks(Traitement).Activate Worksheets("CellData").Activate Worksheets("CellData").Paste Destination:=Range("I1") MrxBSC = Cells(500, 9).End(xlUp).Row 'Fermeture du fichier Application.CutCopyMode = False Workbooks(BSCData).Close SaveChanges:=False 'Debut des traitement 'Worksheets("CellData").Activate MrxCell2 = Cells(7000, 1).End(xlUp).Row 'CellRef Range("A1:A" & MrxCell2).TextToColumns Destination:=Range("CW1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, Comma:=True, Space:=True, Other:=True, OtherChar:="}" 'LAC, CI Range("F1:F" & MrxCell2).TextToColumns Destination:=Range("M1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, Comma:=True, Space:=True, Other:=True, OtherChar:="}" Range("U1:U" & MrxCell2).Copy Destination:=Range("DD1") Range("W1:W" & MrxCell2).Copy Destination:=Range("DE1") 'BSIC Range("C1:C" & MrxCell).TextToColumns Destination:=Range("AB1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, Comma:=True, Space:=True, Other:=True, OtherChar:="}" For brow = 2 To MrxCell Range("AG" & brow) = Range("AD" & brow) & Range("AF" & brow) Next brow Range("AD1:AD" & MrxCell).Copy Destination:=Range("DH1") Range("AF1:AF" & MrxCell).Copy Destination:=Range("DI1") Range("AG1:AG" & MrxCell).Copy Destination:=Range("DG1") 'BSC Range("G1:G" & MrxCell).TextToColumns Destination:=Range("AI1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, Comma:=True, Space:=True, Other:=True, OtherChar:="}" For bscrow = 2 To MrxCell Set bscNum = Range("I1:I" & MrxBSC + 1).Find(Range("AM" & bscrow).Value, LookAt:=xlWhole) If Not bscNum Is Nothing Then Range("AS" & bscrow) = Range("J" & bscNum.Row) End If Next bscrow Range("AS1:AS" & MrxCell).Copy Destination:=Range("DC1") 'CellName & BCCH Range("H1:H" & MrxCell).Copy Destination:=Range("DB1") Range("B1:B" & MrxCell).Copy Destination:=Range("DF1") 'Frequences Range("D1:E" & MrxCell).Replace What:="}", Replacement:=",", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False Range("D1:E" & MrxCell).Replace What:="{", Replacement:=",", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False Range("D1:E" & MrxCell).Replace What:=" ", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False For Freqrow = 2 To MrxCell Range("AT" & Freqrow) = Range("D" & Freqrow) & Range("E" & Freqrow) Next Freqrow For Freqrow3 = 2 To MrxCell C1 = "," & Range("B" & Freqrow3).Value & "," Range("AT" & Freqrow3).Replace What:=C1, Replacement:=",", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False Next Freqrow3 Range("AT1:AT" & MrxCell).TextToColumns Destination:=Range("AU1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, Comma:=True, Space:=True, Other:=False 'Traitement dfes frequences TCH For Freqrow2 = 2 To MrxCell If Not IsEmpty(Range("BO" & Freqrow2)) Then minf = Application.WorksheetFunction.Min(Range("AV" & Freqrow2, "CP" & Freqrow2)) maxf = Application.WorksheetFunction.Max(Range("AV" & Freqrow2, "CP" & Freqrow2)) Range("AV" & Freqrow2, "CP" & Freqrow2).ClearContents Range("AU" & Freqrow2) = "[" & minf & " - " & maxf & "]" End If Next Freqrow2 Range("AU1:BY" & MrxCell).Copy Destination:=Range("DP1") Application.CutCopyMode = False 'Traitement Adjacency Worksheets("AdjacencyData").Activate Range("A1:A" & Mrxadja).TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, Comma:=True, Space:=True, Other:=True, OtherChar:="}" Range("H2:H" & Mrxadja).Copy Destination:=Worksheets("CellData").Range("CT2") Range("N2:N" & Mrxadja).Copy Destination:=Worksheets("CellData").Range("CU2") Worksheets("CellData").Activate 'Tri Range("CT1") = "C_Source" Range("CU1") = "C_Dest" Range("CT1:CU" & Mrxadja).Sort Key1:=Range("CT1"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Range("DA1") = "CellRef" Range("DA1:EZ" & MrxCell).Sort Key1:=Range("DA1"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Application.CutCopyMode = False 'Traitement des voisines Nrow = 2 Nrow2 = 2 Do Set cSource = Range(Cells(Nrow2 - 1, 98), Cells(Nrow2 + 60, 98)).Find(Range("DA" & Nrow).Value, LookIn:=xlValues, LookAt:=xlWhole) If Not cSource Is Nothing Then col = 140 Nrow2 = cSource.Row Do Set cDest = Range("DA1:DA" & MrxCell2).Find(Range("CU" & Nrow2).Value, LookIn:=xlValues, LookAt:=xlWhole) If Not cDest Is Nothing Then ay = cDest.Row AZ = cSource.Row Cells(Nrow, col) = Range("DD" & cDest.Row) Cells(Nrow, col + 1) = Range("DE" & cDest.Row) col = col + 2 Nrow2 = Nrow2 + 1 Else Nrow2 = Nrow2 + 1 End If Loop While Range("CT" & Nrow2 - 1) = Range("CT" & Nrow2) End If Nrow = Nrow + 1 Loop While Nrow <= MrxCell Range("DB2", "IZ" & MrxCell).Copy Destination:=Worksheets("Travail").Range("K" & Mrxtrav + 1) Worksheets("Travail").Activate Mrxtrav = Cells(20000, 11).End(xlUp).Row Application.CutCopyMode = False If j < 5 Then Worksheets("CellData").Activate Range("A1", "IZ" & MrxCell2).ClearContents Worksheets("AdjacencyData").Activate Range("A1", "O" & Mrxadja).ClearContents Worksheets("ExternalOMCData").Activate Range("A1", "O" & MrxExtO).ClearContents End If Next 'Ouverture des données moto MotorolaData = TabFolderName(1) & "\glu*.txt" 'Ouverture du fichier Application.StatusBar = "Opening " & MotorolaData Workbooks.OpenText Filename:=MotorolaData, Origin:=xlMSDOS, _ StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _ ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=True, Comma:=False, _ Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array( _ 3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 2), Array(9, 1), Array(10 _ , 1), Array(11, 1)), TrailingMinusNumbers:=True DataMoto = ActiveWorkbook.Name Range("B1:I10000").Copy 'Collage des données Workbooks(Traitement).Activate Worksheets("MotoData").Activate Worksheets("MotoData").Paste Destination:=Range("A1") MrxMotobsicCle = Cells(20000, 1).End(xlUp).Row 'Suppression des "-" ds la colonne bsic For MotoBSICCL = 2 To MrxMotobsicCle Range("F" & MotoBSICCL).Replace What:="-", Replacement:=0, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False Range("G" & MotoBSICCL).Replace What:="-", Replacement:=1, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False Next MotoBSICCL MrxMoto = Cells(20000, 1).End(xlUp).Row Application.CutCopyMode = False Workbooks(DataMoto).Close SaveChanges:=False 'Ouverture des données terrain AssetData = TabFolderName(1) & "\Asset*.xls" 'Ouverture du fichier Application.StatusBar = "Opening " & AssetData Workbooks.OpenText Filename:=AssetData, local:=True FieldData = ActiveWorkbook.Name Range("A3:Z50000").Copy 'Collage des données Workbooks(Traitement).Activate Worksheets("FieldData").Activate Worksheets("FieldData").Paste Destination:=Range("K1") Mrxfieldold = Cells(50000, 12).End(xlUp).Row 'Formatage de la nouvelle zone de donnée Range("A1") = "Cell_ID" Range("B1") = "Latitude" Range("C1") = "Longitude" Range("D1") = "Antenna_Type" Range("E1") = "Antenna Height" Range("F1") = "Azimuth" Range("G1") = "Total_Tilt" For SDataRowC = 2 To Mrxfieldold Range("AG" & SDataRowC).Value = Range("N" & SDataRowC).Value Next SDataRowC SDataRowL2 = 2 For SDataRow = 2 To Mrxfieldold Nbcheck = Application.WorksheetFunction.IsNumber(Range("AG" & SDataRow).Value) If Nbcheck = True Then Range("U" & SDataRow).Replace What:="-", Replacement:=-1, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False Range("A" & SDataRowL2).Value = Range("AG" & SDataRow).Value Range("B" & SDataRowL2) = Range("M" & SDataRow) Range("C" & SDataRowL2) = Range("L" & SDataRow) Range("D" & SDataRowL2) = Range("O" & SDataRow) Range("E" & SDataRowL2) = Range("R" & SDataRow) Range("F" & SDataRowL2).Value = Range("U" & SDataRow).Value Range("G" & SDataRowL2) = Range("Z" & SDataRow) SDataRowL2 = SDataRowL2 + 1 End If Next SDataRow Mrxfield = Cells(50000, 1).End(xlUp).Row 'fermeture du fichier Application.CutCopyMode = False Workbooks(FieldData).Close SaveChanges:=False 'Traitement données motorola 'Traitement des frequence Worksheets("MotoData").Activate Range("G1:G" & MrxMoto).TextToColumns Destination:=Range("Q1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, Comma:=False, Space:=True, Other:=False For FreqrowM = 2 To MrxMoto If Not IsEmpty(Range("AO" & FreqrowM)) Then minf = Application.WorksheetFunction.Min(Range("R" & FreqrowM, "BL" & FreqrowM)) maxf = Application.WorksheetFunction.Max(Range("R" & FreqrowM, "BL" & FreqrowM)) Range("R" & FreqrowM, "BL" & FreqrowM).ClearContents Range("BA" & FreqrowM) = "[" & minf & " - " & maxf & "]" End If Next FreqrowM Range("BA2:BA" & MrxMoto).Copy Destination:=Worksheets("Travail").Range("Y" & Mrxtrav + 1) Range("R2:AO" & MrxMoto).Copy Destination:=Worksheets("Travail").Range("Z" & Mrxtrav + 1) 'BCCH Range("Q2:Q" & MrxMoto).Copy Destination:=Worksheets("Travail").Range("O" & Mrxtrav + 1) 'CellName Range("E2:E" & MrxMoto).Copy Destination:=Worksheets("Travail").Range("K" & Mrxtrav + 1) 'BSC Range("A2:A" & MrxMoto).Copy Destination:=Worksheets("Travail").Range("L" & Mrxtrav + 1) 'LAC CI Range("D1:D" & MrxMoto).TextToColumns Destination:=Range("K1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, Comma:=False, Space:=True, Other:=True, OtherChar:="-" Range("M2:N" & MrxMoto).Copy Destination:=Worksheets("Travail").Range("M" & Mrxtrav + 1) 'Traitement BSIC For rowbsic = 2 To MrxMoto If Range("F" & rowbsic) <> "-" Then Range("J" & rowbsic) = Application.WorksheetFunction.Dec2Oct(Range("F" & rowbsic)) Range("BZ" & rowbsic) = Right(Range("J" & rowbsic), 1) Range("BY" & rowbsic) = (Range("J" & rowbsic).Value - Range("BZ" & rowbsic).Value) / 10 End If Next rowbsic Range("J2:J" & MrxMoto).Copy Destination:=Worksheets("Travail").Range("P" & Mrxtrav + 1) Range("BY2:BY" & MrxMoto).Copy Destination:=Worksheets("Travail").Range("Q" & Mrxtrav + 1) Range("BZ2:BZ" & MrxMoto).Copy Destination:=Worksheets("Travail").Range("R" & Mrxtrav + 1) 'Traitement voisines Range("H2:H" & MrxMoto).Replace What:="602-01-", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False Range("H2:H" & MrxMoto).TextToColumns Destination:=Range("CA2"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, Comma:=False, Space:=True, Other:=True, OtherChar:="-" Range("CA2:DZ" & MrxMoto).Copy Destination:=Worksheets("Travail").Range("AS" & Mrxtrav + 1) 'Copie Field Data Worksheets("FieldData").Activate Range("A1:G" & Mrxfield).Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Range("A1:G" & Mrxfield).Copy Destination:=Worksheets("Travail").Range("A1") 'Ajout des Field Data Worksheets("Travail").Activate Mrxfielddata = Cells(20000, 14).End(xlUp).Row 'TRI Range("N1") = "CI" Range("K1:EZ" & Mrxfielddata).Sort Key1:=Range("N1"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom lim = 1 For Rowdf = 2 To Mrxfielddata Set cfieldata = Range(Cells(lim, 1), Cells(Mrxfield, 1)).Find(Range("N" & Rowdf).Value, LookAt:=xlWhole, LookIn:=xlValues) ' Range("A1:A" & Mrxfield) If Not cfieldata Is Nothing Then Range(Cells(cfieldata.Row, 2), Cells(cfieldata.Row, 7)).Copy Destination:=Range("S" & Rowdf) lim = cfieldata.Row End If Next Rowdf rowm = 2 Do Range("AR" & rowm) = Application.WorksheetFunction.Count(Range("AS" & rowm, "EI" & rowm)) Range("EJ" & rowm) = Application.WorksheetFunction.Count(Range("Y" & rowm, "AQ" & rowm)) rowm = rowm + 1 Loop While rowm < Mrxfielddata + 1 MaxHO = Application.WorksheetFunction.Max(Range("AR2:AR" & Mrxfielddata)) / 2 MaxTCH = Application.WorksheetFunction.Max(Range("EJ2:EJ" & Mrxfielddata)) 'Suppression des données unitiles Range("K1:EZ" & Mrxfielddata).Sort Key1:=Range("S1"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Mrxfielddata = Cells(20000, 19).End(xlUp).Row 'CAS FICHIER CEL 'Transfert des données Range("K2:K" & Mrxfielddata).Copy Destination:=Worksheets("FichierCel").Range("A3") 'CellName Range("O2:P" & Mrxfielddata).Copy Destination:=Worksheets("FichierCel").Range("B3") 'BCCH-BSIC Range("S2:T" & Mrxfielddata).Copy Destination:=Worksheets("FichierCel").Range("D3") 'LAT-LON Range("M2:N" & Mrxfielddata).Copy Destination:=Worksheets("FichierCel").Range("H3") 'LAC-CI Range("W2:W" & Mrxfielddata).Copy Destination:=Worksheets("FichierCel").Range("J3") 'Azimuth Range(Cells(2, 25), Cells(Mrxfielddata, 25 + MaxTCH)).Copy Destination:=Worksheets("FichierCel").Range("K3") ' frequences Range(Cells(2, 45), Cells(Mrxfielddata, 45 + MaxHO * 2)).Copy Destination:=Worksheets("FichierCel").Cells(3, 12 + MaxTCH) 'HO 'creation du fichier cel 'Workbooks.Add 'fichier.cel = ActiveWorkbook.Name 'formatage du fichier Worksheets("FichierCel").Activate With Worksheets("FichierCel") .Range("A1") = "2 TEMS_-_Cell_names" .Range("A2") = "CELL" .Range("B2") = "ARFCN" .Range("C2") = "BSIC" .Range("D2") = "LAT" .Range("E2") = "LON" .Range("F2") = "MCC" .Range("G2") = "MNC" .Range("H2") = "LAC" .Range("I2") = "CI" .Range("J2") = "ANT_DIRECTION" .Range("K2") = "ANT_BEAM_WIDTH" RowHO = 1 Do .Cells(2, (28 + 2 * RowHO)) = "LAC_N_" & RowHO .Cells(2, (29 + 2 * RowHO)) = "CI_N_" & RowHO RowHO = RowHO + 1 Loop While RowHO <= MaxHO RowTCH = 1 Do .Cells(2, (11 + RowTCH)) = "TCH_ARFCN_" & RowTCH RowTCH = RowTCH + 1 Loop While RowTCH <= MaxTCH End With rowFC = 3 Do Range("F" & rowFC) = "602" Range("G" & rowFC) = "01" If Range("B" & rowFC) < 200 Then Range("K" & rowFC) = "70" Else Range("K" & rowFC) = "35" End If rowFC = rowFC + 1 Loop While rowFC < Mrxfielddata + 1 'Piano Worksheets("Travail").Activate 'Range("B2:C" & Mrxfield).Select 'Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False Range("K2:AQ" & Mrxfielddata).Copy Destination:=Worksheets("Piano").Range("A2") Range("AR2:AR" & Mrxfielddata).Copy Destination:=Worksheets("Piano").Range("AZ2") Worksheets("Piano").Activate With Worksheets("Piano") .Range("A1") = "CellName" .Range("B1") = "BSC" .Range("C1") = "LAC" .Range("D1") = "CI" .Range("E1") = "BCCH" .Range("F1") = "BSIC" .Range("G1") = "NCC" .Range("H1") = "BCC" .Range("I1") = "LAT" .Range("J1") = "LON" .Range("K1") = "ANTENNA_TYPE" .Range("L1") = "ANTENNA_HEIGHT" .Range("M1") = "AZIMUTH" .Range("N1") = "TILT" .Range("O1") = "MA_LIST" RowTCH = 1 Do .Cells(1, (15 + RowTCH)) = "CU" & RowTCH + 1 RowTCH = RowTCH + 1 Loop While RowTCH < MaxTCH End With Cells(1, (15 + MaxTCH)) = "LENGHT" Cells(1, (16 + MaxTCH)) = "NB_HO" rowpn = 2 Do Cells(rowpn, (15 + MaxTCH)).Value = 1 / 10 If Range("AZ" & rowpn).Value <> "0" Then Cells(rowpn, (16 + MaxTCH)) = Range("AZ" & rowpn).Value / 2 Else Cells(rowpn, (16 + MaxTCH)) = "0" End If rowpn = rowpn + 1 Loop While rowpn <= Mrxfielddata 'TRF2000 Worksheets("Travail").Activate Range("K2:X" & Mrxfielddata).Copy Destination:=Worksheets("TRF2000").Range("B2") Range(Cells(2, 25), Cells(Mrxfielddata, 25 + MaxTCH)).Copy Destination:=Worksheets("TRF2000").Range("P2") ' frequences Range("AR2:AR" & Mrxfielddata).Copy Destination:=Worksheets("TRF2000").Range("CZ2") TRF = 1 Do Range(Cells(2, 44 + 2 * TRF), Cells(Mrxfielddata, 44 + 2 * TRF)).Copy Destination:=Worksheets("TRF2000").Cells(2, 16 + MaxTCH + TRF) 'HO TRF = TRF + 1 Loop While TRF <= MaxHO Worksheets("TRF2000").Activate With Worksheets("TRF2000") .Range("A1") = "S_No" .Range("B1") = "SITENAME" .Range("C1") = "BSC_NAME" .Range("D1") = "LOCATION_AREA_CODE" .Range("E1") = "CellId" .Range("F1") = "BCCH" .Range("G1") = "BSIC" .Range("H1") = "NCC" .Range("I1") = "BCC" .Range("J1") = "LATITUDE" .Range("K1") = "LONGITUDE" .Range("L1") = "Existing_Antenna" .Range("M1") = "Height__m_" .Range("N1") = "AntAzimuth" .Range("O1") = "TILT" .Range("P1") = "MA_LIST" RowTCH = 1 Do .Cells(1, (16 + RowTCH)) = "freq" & RowTCH RowTCH = RowTCH + 1 Loop While RowTCH <= MaxTCH RowHO = 1 Do .Cells(1, (34 + RowHO)) = "N" & RowHO RowHO = RowHO + 1 Loop While RowHO <= MaxHO End With rowpn = 2 Do Cells(rowpn, 1) = rowpn - 1 If Range("CZ" & rowpn).Value <> "0" Then Cells(rowpn, (17 + MaxTCH + MaxHO)) = Range("CZ" & rowpn).Value / 2 Else Cells(rowpn, (17 + MaxTCH + MaxHO)) = "0" End If rowpn = rowpn + 1 Loop While rowpn <= Mrxfielddata Range("B2:B" & Mrxfielddata).Copy Destination:=Cells(2, (16 + MaxTCH + MaxHO)) Cells(1, (16 + MaxTCH + MaxHO)) = "BTSNAME" Cells(1, (17 + MaxTCH + MaxHO)) = "NB_HO" Application.ScreenUpdating = True Do fileSaveName = Application.GetSaveAsFilename(InitialFileName:="Please Select Output Folder", Title:="SELECT THE OUTPUT FOLDER") Loop Until fileSaveName <> False Application.ScreenUpdating = False MyPos = InStrRev(fileSaveName, stringmatch:="") Rep = Mid(fileSaveName, 1, MyPos) Djour = Day(Date) & Month(Date) & Year(Date) Application.SheetsInNewWorkbook = 1 'Fichier cell Worksheets("FichierCel").Activate Range("A1:DZ" & Mrxfielddata).Copy Workbooks.Add FCell = ActiveWorkbook.Name With ActiveWorkbook.ActiveSheet .Name = "TEMS_CEL_" & Djour .Range("A1").Select .Paste End With 'Nom des fichiers de sortir fnameFCell = Rep & "TEMS_CEL_" & Djour & "." & "cel" Workbooks(FCell).SaveAs Filename:=fnameFCell, FileFormat:=xlText, CreateBackup:=False ActiveWorkbook.Close SaveChanges:=False 'Piano Worksheets("Piano").Activate Range("A1:AY" & Mrxfielddata).Copy Workbooks.Add FPiano = ActiveWorkbook.Name With ActiveWorkbook.ActiveSheet .Name = "PIANO_" & Djour .Range("A1").Select .Paste End With 'Nom des fichiers de sortir fnameFPiano = Rep & "PIANO_" & Djour & ".xls" Workbooks(FPiano).SaveAs Filename:=fnameFPiano, FileFormat:=xlExcel8, CreateBackup:=False ActiveWorkbook.Close SaveChanges:=False 'TRF2000 Worksheets("TRF2000").Activate Range("A1:CY" & Mrxfielddata).Copy Workbooks.Add FTRF200 = ActiveWorkbook.Name With ActiveWorkbook.ActiveSheet .Name = "TRF_" & Djour .Range("A1").Select .Paste End With 'Nom des fichiers de sortir fnameFTRF2000 = Rep & "TRF_" & Djour & ".xls" Workbooks(FTRF200).SaveAs Filename:=fnameFTRF2000, FileFormat:=xlExcel8, CreateBackup:=False ActiveWorkbook.Close SaveChanges:=False Application.SheetsInNewWorkbook = 3 Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.SheetsInNewWorkbook = 3 Workbooks(Traitement).Close SaveChanges:=False Application.CutCopyMode = True End Sub

ricomiracle · Answer

Tu ouvres un classeur à chaque fois que tu traites un fichier?

Pourquoi tu travail pas sur le fichier directement (avec la référence Microsoft Scipting Runtime)

cs_bambival · Answer

En fait je ne suis pas programmeur ce progremme a ete realise avec l aide tout simple,
les suggestions sont les bienvenues

cs_rt15 · Answer

Salut,

Pour un problème VBA, poster sur vbfrance dans le thème VBA.

[ Déplacé sur vbfrance ]

Execution macro excel

5 réponses

Votre réponse

Discussions similaires