captaindidi
XLDnaute Nouveau
Bonjour,
J'ai 2 fichiers:
- le 1er contient les données concernant environ 50 entreprises (à minima 50 lignes par entreprises)
- le 2e permet de calculer des statistiques (les mêmes) en fonction des données situés dans l'onglet Data
J'aimerai une macro qui copie les données (fichier n°1) de chaque entreprise dans l'onglet Data (fichier n°2) et qui avant enregistré met à jour tous les TCD et les calculs.
J'ai trouvé cette macro mais il copie les données (fichier 1) par entreprise dans un nouveau fichier vierge. Aujourd'hui je copie/colle les données à la main dans le 2e fichier.
Pourriez-vous m'aider
Sub Decoupage()
Dim nwbk As Workbook
Dim dl&, dc%, i&, iDeb&, iFn&
Dim ws As Worksheet, r As Range, iCl%
On Error Resume Next
With ActiveSheet
Set r = .Range([A2], .[A65536].End(xlUp))
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCl = r.Column
Application.ScreenUpdating = False
dl = .Cells(Rows.Count, "A").End(xlUp).Row
dc = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range(.Cells(2, 1), .Cells(dl, dc)).Sort Key1:=.Cells(2, iCl), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
iDeb = 2
For i = 2 To dl
If .Cells(i, iCl).Value <> .Cells(i + 1, iCl).Value Then
iFn = i
Workbooks.Add xlWBATWorksheet
Set nwbk = ActiveWorkbook
Set ws = nwbk.Sheets(1)
On Error Resume Next
ws.Name = .Cells(iDeb, iCl).Text
On Error GoTo 0
Range(.Cells(1, 1), .Cells(1, dc)).Copy
ws.[A1].PasteSpecial xlValues
ws.[A1].PasteSpecial xlFormats
Range(.Cells(iDeb, 1), .Cells(iFn, dc)).Copy ws.Range("A2")
nwbk.SaveAs "C:\Temp\" & ws.Name
nwbk.Close True
iDeb = iFn + 1
End If
Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
J'ai 2 fichiers:
- le 1er contient les données concernant environ 50 entreprises (à minima 50 lignes par entreprises)
- le 2e permet de calculer des statistiques (les mêmes) en fonction des données situés dans l'onglet Data
J'aimerai une macro qui copie les données (fichier n°1) de chaque entreprise dans l'onglet Data (fichier n°2) et qui avant enregistré met à jour tous les TCD et les calculs.
J'ai trouvé cette macro mais il copie les données (fichier 1) par entreprise dans un nouveau fichier vierge. Aujourd'hui je copie/colle les données à la main dans le 2e fichier.
Pourriez-vous m'aider
Sub Decoupage()
Dim nwbk As Workbook
Dim dl&, dc%, i&, iDeb&, iFn&
Dim ws As Worksheet, r As Range, iCl%
On Error Resume Next
With ActiveSheet
Set r = .Range([A2], .[A65536].End(xlUp))
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCl = r.Column
Application.ScreenUpdating = False
dl = .Cells(Rows.Count, "A").End(xlUp).Row
dc = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range(.Cells(2, 1), .Cells(dl, dc)).Sort Key1:=.Cells(2, iCl), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
iDeb = 2
For i = 2 To dl
If .Cells(i, iCl).Value <> .Cells(i + 1, iCl).Value Then
iFn = i
Workbooks.Add xlWBATWorksheet
Set nwbk = ActiveWorkbook
Set ws = nwbk.Sheets(1)
On Error Resume Next
ws.Name = .Cells(iDeb, iCl).Text
On Error GoTo 0
Range(.Cells(1, 1), .Cells(1, dc)).Copy
ws.[A1].PasteSpecial xlValues
ws.[A1].PasteSpecial xlFormats
Range(.Cells(iDeb, 1), .Cells(iFn, dc)).Copy ws.Range("A2")
nwbk.SaveAs "C:\Temp\" & ws.Name
nwbk.Close True
iDeb = iFn + 1
End If
Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
