O
olivius
Guest
Bonjour à tous,
je souhaiterais utiliser cette macro mais elle bug dès le départ..
Pourriez vous m'aider svp ?
Sub CreateExtractionReport()
Dim Ligne As Integer
Ligne = 1
Dim ValeurCellulePrecedente As String
ValeurCellulePrecedente = ""
Dim I As Integer
Dim J As Integer
I = 1
J = 1
'Application.ScreenUpdating = False ' Neutraliser l'affichage à l'écran
' **************************************************
' Ouverture du fichier Source
fichierSource = Application.GetOpenFilename("Fichiers Excels(*.xl*),*xl*")
If fichierSource = False Then
Exit Sub
End If
' **************************************************
Workbooks.Open fichierSource
Nom = ActiveWorkbook.Name
Workbooks(Nom).Activate
ActiveSheet.Select
FeuilleSource = ActiveSheet.Name
Sheets(FeuilleSource).Select
' **************************************************
' Extraction
For Each cell In Worksheets(FeuilleSource).Range("B15", Range("B15").End(xlDown))
If ValeurCellulePrecedente <> cell.Text Then
Worksheets(FeuilleSource).Rows(cell.Row).Copy Destination:=Worksheets("Extraction").Range("A" & Ligne)
Workbooks("Results_SP.xlsm").Activate
Worksheets("Extraction").Activate
ActiveSheet.Paste
Worksheets("Extraction").Range("P" & Ligne).Value = 1
Worksheets("Extraction").Range("P" & Ligne).NumberFormat = "0"
ValeurCellulePrecedente = cell.Text
Ligne = Ligne + 1
Sheets(FeuilleSource).Select
Else
Worksheets("Extraction").Range("P" & Ligne - 1).Value = Worksheets("Extraction").Range("P" & Ligne - 1).Value + 1
End If
Next cell
End Sub
je souhaiterais utiliser cette macro mais elle bug dès le départ..
Pourriez vous m'aider svp ?
Sub CreateExtractionReport()
Dim Ligne As Integer
Ligne = 1
Dim ValeurCellulePrecedente As String
ValeurCellulePrecedente = ""
Dim I As Integer
Dim J As Integer
I = 1
J = 1
'Application.ScreenUpdating = False ' Neutraliser l'affichage à l'écran
' **************************************************
' Ouverture du fichier Source
fichierSource = Application.GetOpenFilename("Fichiers Excels(*.xl*),*xl*")
If fichierSource = False Then
Exit Sub
End If
' **************************************************
Workbooks.Open fichierSource
Nom = ActiveWorkbook.Name
Workbooks(Nom).Activate
ActiveSheet.Select
FeuilleSource = ActiveSheet.Name
Sheets(FeuilleSource).Select
' **************************************************
' Extraction
For Each cell In Worksheets(FeuilleSource).Range("B15", Range("B15").End(xlDown))
If ValeurCellulePrecedente <> cell.Text Then
Worksheets(FeuilleSource).Rows(cell.Row).Copy Destination:=Worksheets("Extraction").Range("A" & Ligne)
Workbooks("Results_SP.xlsm").Activate
Worksheets("Extraction").Activate
ActiveSheet.Paste
Worksheets("Extraction").Range("P" & Ligne).Value = 1
Worksheets("Extraction").Range("P" & Ligne).NumberFormat = "0"
ValeurCellulePrecedente = cell.Text
Ligne = Ligne + 1
Sheets(FeuilleSource).Select
Else
Worksheets("Extraction").Range("P" & Ligne - 1).Value = Worksheets("Extraction").Range("P" & Ligne - 1).Value + 1
End If
Next cell
End Sub