Macro Excel devenue lente avec Erreur -2147417848 (80010108)

Signaler
Messages postés
6
Date d'inscription
mardi 24 février 2009
Statut
Membre
Dernière intervention
1 septembre 2009
-
Messages postés
6
Date d'inscription
mardi 24 février 2009
Statut
Membre
Dernière intervention
1 septembre 2009
-
Bonjour à tous,

j'ai ecris une macro sous excel pour le traitement de certaine et tout marchait bien.
mais depuis que j'ai installé .NET Framework 3.5 ma macro est devenue tres lente et ne s'execute plus jusqu'au bout elle me done l'erreur suivant apres environ 10mn Erreur  -2147417848 (80010108) La Méthode Replace de l'objet range a échoué. 

J'ai désintallé  .NET Framework 3.5 aucun changement,
J'ai désintallé  office 2007 aucun changement
J'ai meme désintallé windows le problème persiste.

je ne comprends donc plus rien, une macro qui marchait normalement et d'un coup comme ne devient hyper lente et ne s'execute plus jusqu'au bout.

chers developpeur votre aide sera la bienvenue.

ci dessous le code

Sub Bouton1_Clic()
'Outils de génération de donnés pour fichier cel, Piano et TRF200
'Conçu le 16 Aôut 2008


oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual
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) & "\eomc5"
TabFileName(3) = TabFolderName(1) & "\eomc6"
TabFileName(4) = TabFolderName(1) & "\eomc3"
TabFileName(5) = TabFolderName(1) & "\eomc4"




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, EG2:EG5000, EJ2:EJ5000, ER2:ER5000, ES2:ES5000, EV2:EV5000, IW2:IW5000, KG2:KG5000").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,LW2:LW1000").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")




 '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
 
 'Traitement des voisines


 Nrow = 2
 Nrow2 = 2
 Do
    Set cSource = Range(Cells(Nrow2 - 1, 98), Cells(Mrxadja, 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
               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


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

3 réponses

Messages postés
577
Date d'inscription
vendredi 26 septembre 2008
Statut
Membre
Dernière intervention
20 novembre 2010
4
Bonjour

J'ai compté une dizaine de méthodes Replace dans ton code. Comment puis-je savoir laquelle échoue ? A toi de le préciser.

Cordialement

PS : Avec un code d'une telle taille, on ne peut plus parler de macro ; il vaut mieux parler de ... baleine (je sais, je sais, c'est un peu facile, mais j'ai pas pu résister ).
Messages postés
2065
Date d'inscription
lundi 11 avril 2005
Statut
Membre
Dernière intervention
14 mars 2016
8
Bonjour,

lol, Orohena...

Perso, je me demande pourquoi mettre tout sur le dos de la macro ?... Est-ce que les autres macros (si il y en a) fonctionnement sans ralentissements ?

 Ensuite, je reste dubitatif devant la recherche de la solution :
"J'ai désintallé  .NET Framework 3.5 aucun changement, "
Je ne vois pas ce que le Framework vient faire dans l'affaire. Le VBA ne s'en sert pas.
"J'ai désintallé  office 2007 aucun changement"
Euh... là, c'est dur de faire tourner Excel... (Réinstaller ensuite, je présume...)
"J'ai meme désintallé windows le problème persiste."


Les grands moyens !



Pourquoi ne pas passer un anti-virus avant tout ?


Amicalement,
Us.
Messages postés
6
Date d'inscription
mardi 24 février 2009
Statut
Membre
Dernière intervention
1 septembre 2009

Salut a tous,

le truc c'est que le pb a commencé après que j'aie installé .Net Framework 3.5 donc il était raisonnable que je le desonstalle pour voir.

ma Macro ou Baleine marchait tres avant donc je ne comprends pas trop ce qui a du se passer.