Bonjour
J'ai ecris ce code
lorsque je le lance j'ai "mémoire insuffisante"
Le fichier que je vais chercher fait environ 2500 lignes
Une idée ?
J'ai ecris ce code
VB:
Sub ImporterEtInsererFormules_Et_Traiter() '- Ctrl + i
Dim fd As FileDialog
Dim cheminFichier As String
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wbDest As Workbook
Dim wsDest As Worksheet
Dim wsCopy As Worksheet
Dim lastRow As Long
Dim lastCol As Long
Dim plageACopier As Range
Dim i As Long
Dim nomNouvelleFeuille As String
Dim dtPremierJourMois As Date
Dim lastRowCopy As Long
' --------- Importer et insérer formules (ton code d'origine) ---------
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Sélectionnez le fichier Excel à importer"
.Filters.Clear
.Filters.Add "Fichiers Excel", "*.xls; *.xlsx; *.xlsm"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
cheminFichier = .SelectedItems(1)
End With
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wbSource = Workbooks.Open(cheminFichier, UpdateLinks:=0, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
Set wsSource = wbSource.Sheets(1)
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
Set plageACopier = wsSource.Range(wsSource.Cells(2, 1), wsSource.Cells(lastRow, lastCol))
Set wbDest = ThisWorkbook
Set wsDest = wbDest.Sheets("Abs GTA")
' Copier directement sans message presse-papiers
plageACopier.Copy Destination:=wsDest.Range("A2")
' Copier les hauteurs de lignes
For i = 2 To lastRow
wsDest.Rows(i).RowHeight = wsSource.Rows(i).RowHeight
Next i
wbSource.Close SaveChanges:=False
With wsDest
' Insérer formules ligne 2
.Cells(2, "AA").FormulaLocal = "=SI(B1=B2;SI((U2+1)=T3;""N"";""O"");""N"")"
.Cells(2, "AB").FormulaLocal = "=SI(B2=B1;SI((U1+1)=T2;AB1+Y2;Y2);Y2)"
.Cells(2, "AC").FormulaLocal = "=SI(AA2=""O"";SI(AB2>=16;AB2;0);0)"
.Cells(2, "AD").FormulaLocal = "=T2"
.Cells(2, "AE").FormulaLocal = "=U2"
' Insérer formules à partir ligne 3
For i = 3 To lastRow
.Cells(i, "AA").FormulaLocal = "=SI(B" & (i - 1) & "=B" & i & ";SI((U" & i & "+1)=T" & (i + 1) & ";""N"";""O"");""N"")"
.Cells(i, "AB").FormulaLocal = "=SI(B" & i & "=B" & (i - 1) & ";SI((U" & (i - 1) & "+1)=T" & i & ";AB" & (i - 1) & "+Y" & i & ";Y" & i & ");Y" & i & ")"
.Cells(i, "AC").FormulaLocal = "=SI(AA" & i & "=""O"";SI(AB" & i & ">=16;AB" & i & ";0);0)"
.Cells(i, "AD").FormulaLocal = "=SI(B" & i & "=B" & (i - 1) & ";SI((U" & (i - 1) & "+1)=AE" & i & "-(AB" & i & "-1);AE" & (i - 1) & ";AE" & i & "-(AB" & i & "-1));AE" & i & "-(AB" & i & "-1))"
.Cells(i, "AE").FormulaLocal = "=U" & i
Next i
.Range("AD2:AD" & lastRow).NumberFormat = "dd/mm/yyyy"
End With
' --------- Duplication de la feuille ---------
dtPremierJourMois = DateSerial(Year(Date), Month(Date), 1)
nomNouvelleFeuille = "SS_" & Format(dtPremierJourMois, "ddmmyyyy")
On Error Resume Next
Application.DisplayAlerts = False
wbDest.Sheets(nomNouvelleFeuille).Delete
Application.DisplayAlerts = True
On Error GoTo 0
wsDest.Copy After:=wbDest.Sheets(wbDest.Sheets.Count)
Set wsCopy = wbDest.Sheets(wbDest.Sheets.Count)
wsCopy.Name = nomNouvelleFeuille
' --------- Coller valeurs dans AA:AE (remplacer formules par valeurs) ---------
With wsCopy
.Range("AA2:AE" & lastRow).Value = .Range("AA2:AE" & lastRow).Value
End With
' --------- Suppression des lignes selon critères ---------
With wsCopy
For i = lastRow To 2 Step -1
If .Cells(i, "AA").Value = "N" Then
.Rows(i).Delete
ElseIf .Cells(i, "AC").Value = 0 Then
.Rows(i).Delete
End If
Next i
End With
' --------- Insertion de colonnes et titres ---------
With wsCopy
Dim colW As Long, colAJ As Long, colAK As Long, colAM As Long
colW = .Columns("W").Column
colAJ = .Columns("AJ").Column
' Insérer 4 colonnes avant W
Dim n As Long
For n = 1 To 4
.Columns(colW).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Next n
.Cells(1, colW).Value = "12 mois précédent arrêt"
.Cells(1, colW + 1).Value = "mois précédent arrêt"
.Cells(1, colW + 2).Value = "nb de mois salaire"
.Cells(1, colW + 3).Value = "contrôle"
With .Range(.Cells(1, colW), .Cells(1, colW + 3))
.Interior.Color = RGB(255, 255, 204)
.Font.Color = RGB(255, 0, 0)
.Font.Bold = True
End With
' Insérer 4 colonnes avant AJ
For n = 1 To 4
.Columns(colAJ).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Next n
.Cells(1, colAJ).Value = "Date de prise en charge"
.Cells(1, colAJ + 1).Value = "Q424 début arrêt"
.Cells(1, colAJ + 2).Value = "Salaire rétabli sur 12 mois"
.Cells(1, colAJ + 3).Value = "12 mois NET 80% Brut"
With .Range(.Cells(1, colAJ), .Cells(1, colAJ + 3))
.Interior.Color = RGB(255, 192, 0)
.Font.Color = RGB(0, 0, 0)
.Font.Bold = True
End With
' Mise en forme colonnes AK et AM
colAK = .Columns("AK").Column
colAM = .Columns("AM").Column
With .Cells(1, colAK)
.Interior.Color = RGB(173, 216, 230)
.Font.Color = RGB(0, 0, 0)
.Font.Bold = True
End With
With .Cells(1, colAM)
.Interior.Color = RGB(173, 216, 230)
.Font.Color = RGB(0, 0, 0)
.Font.Bold = True
End With
.Columns.AutoFit
End With
' --------- Suppression des colonnes ---------
With wsCopy
' Supprimer dans l'ordre de droite à gauche pour éviter décalage
.Columns("AF").Delete
.Columns("AE").Delete
.Columns("AD").Delete
.Columns("AC").Delete
.Columns("AB").Delete
.Columns("V").Delete
.Columns("U").Delete
.Columns("T").Delete
End With
' --------- Insertion formules T, U, V et concaténation colonne C ---------
With wsCopy
lastRowCopy = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("T2:V" & lastRowCopy).NumberFormat = "General"
For i = 2 To lastRowCopy
.Cells(i, "T").FormulaLocal = "=MOIS.DECALER(Z" & i & ";-12)-(JOUR(Z" & i & ")-1)"
.Cells(i, "U").FormulaLocal = "=MOIS.DECALER(T" & i & ";11)"
.Cells(i, "V").FormulaLocal = "=SI(T" & i & ">J" & i & ";12;MOIS(U" & i & "-MOIS.DECALER(J" & i & ";-1)))"
.Cells(i, "C").NumberFormat = "@"
.Cells(i, "C").Value = "'" & .Cells(i, "B").Value & "." & CLng(.Cells(i, "Z").Value)
Next i
.Range("T2:T" & lastRowCopy).NumberFormat = "dd/mm/yyyy"
.Range("U2:U" & lastRowCopy).NumberFormat = "dd/mm/yyyy"
.Range("V2:V" & lastRowCopy).NumberFormat = "0"
.Calculate
Application.Calculate
End With
' --------- Suppression des lignes selon critères ---------
With wsCopy
For i = lastRow To 2 Step -1
Dim valI As String
valI = UCase(Trim(.Cells(i, "I").Value))
If valI = "MET" Or valI = "MTC" Then
.Rows(i).Delete
End If
Next i
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "Traitement terminé avec succès. Aprés avoir fait quelques contrôles, faire Ctrl + d pour effectuer l'import de la DSN", vbInformation
End Sublorsque je le lance j'ai "mémoire insuffisante"
Le fichier que je vais chercher fait environ 2500 lignes
Une idée ?
