GADENSEB
XLDnaute Impliqué
Bonjour,
Je cherche à réutiliser une vieille macro .XLA qui fonctionné bien sous sous excel 2016.
Depuis que je suis passé sous office 64 cela ne fonctionne plus
La macro créer des fichiers séparés en fonction de la colonne choisie.
A ce que j'ai vu sur internet cela vient de
Comment corriger ?
QQn aurait une idée ?
Je n'ai pas pu inclure le fichier .xla. le site na pas voulu.
Bonne Aprem
Seb
Je cherche à réutiliser une vieille macro .XLA qui fonctionné bien sous sous excel 2016.
Depuis que je suis passé sous office 64 cela ne fonctionne plus
La macro créer des fichiers séparés en fonction de la colonne choisie.
A ce que j'ai vu sur internet cela vient de
Code:
Public Declare Function FindWindowA Lib "user32" _Comment corriger ?
QQn aurait une idée ?
Je n'ai pas pu inclure le fichier .xla. le site na pas voulu.
Bonne Aprem
Seb
VB:
Option Explicit
'**************
'Variables pour supprimer la barre de titre dans l'userform
'===========================================================
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Const GWL_STYLE = (-16)
Const WS_CAPTION = &HC00000
Const SWP_FRAMECHANGED = &H20
Public Declare Function FindWindowA Lib "user32" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias _
"SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, _
ByVal y As Long, ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long) As Long
'**************
'
' compileARTT Macro
' Macro enregistrée le 09/10/2014 Par Sébastien GADEN
'
Sub Decoupage()
Dim Service As New Collection
Dim Plage As Range
Dim col3 As Integer
Dim L As Long, L2 As Long, Lmax As Long
Dim nomcommun, repertoire As String
Dim PctDone
'évite le scintillement de l'écran
Application.ScreenUpdating = False
nomcommun = InputBox("Entrez un nom commun pour les fichiers : ", "Nom des fichiers")
repertoire = SelectionRep
With ActiveSheet
'With Sheets("Feuil1") 'A adapter en fonction de la feuille où sont les données!
Lmax = .Cells(Application.Rows.Count, 1).End(xlUp).Row
'Création de la liste des services (sans doublons)
col3 = InputBox(Prompt:="Quel est le n° de colonne pour le tri?")
On Error Resume Next
For L = 2 To Lmax
Service.Add .Cells(L, col3).Text, .Cells(L, col3).Text
Next L
On Error GoTo 0
'Création des classeurs
For L = 1 To Service.Count
'Copie de l'onglet
.Copy
'Epurage des données par service
With ActiveSheet
Set Plage = .Rows(Application.Rows.Count)
For L2 = 2 To Lmax
If .Cells(L2, col3).Text <> Service(L) Then
Set Plage = Union(Plage, .Rows(L2))
End If
Next L2
Plage.Delete
End With
'Sauvegarde classeur "Catégorie X"
With ActiveWorkbook
'On Error GoTo erreur 'a utiliser si on ne désire pas que le fichier soit supprimer automatiquement si il existe
'mettre en commentaire les lignes avec Application.DisplayAlerts si on ne veut pas un écrasement automatique
Application.DisplayAlerts = False ' attention que si le fichier existe déjà, celui-ci sera écrasé !!!!!
.SaveAs repertoire & "\" & nomcommun & "_" & Service(L) & ".xlsx"
Application.DisplayAlerts = True
'ActiveWorkbook.SendMail Recipients:=Range("A2").Value
.Close
End With
PctDone = (L / Lmax - 1)
DoEvents
Call UpdateProgress(L, Lmax - 1)
Barre_Progression.Show vbModeless
Next L
End With
Application.ScreenUpdating = True
MsgBox Service.Count & " classeurs créés"
Unload Barre_Progression
Exit Sub
'erreur:
' If Err = 1004 Then
' MsgBox "le nom de fichier existe déjà", vbInformation + vbOKOnly, "Fichier existant"
' nomcommun = InputBox("Entrez un nom commun pour les fichiers : ", "Nom des fichiers")
' Resume
' End If
End Sub
Function SelectionRep() As String
Const ssfTous = &H1
Dim objShell As Object, objFolder As Object, oFolderItem As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", ssfTous)
If objFolder Is Nothing Then Exit Function
Set oFolderItem = objFolder.Items.Item
SelectionRep = oFolderItem.Path
Set objShell = Nothing
Set objFolder = Nothing
Set oFolderItem = Nothing
End Function
Sub UpdateProgress(Pct, nbrfich)
With Barre_Progression
.FrameProgress.Caption = Format(Pct / nbrfich, "0%")
.LabelProgress.Width = Pct / nbrfich * (.FrameProgress.Width - 10)
.Repaint
End With
End Sub
Sub AfficheTitleBarre(stCaption As String, pbVisible As Boolean)
Dim vrWin As RECT
Dim style As Long
Dim lHwnd As Long
'- Recherche du handle de la fenêtre par son Caption
lHwnd = FindWindowA(vbNullString, stCaption)
If lHwnd = 0 Then
MsgBox "Handle de " & stCaption & " Introuvable", vbCritical
Exit Sub
End If
GetWindowRect lHwnd, vrWin
style = GetWindowLong(lHwnd, GWL_STYLE)
If pbVisible Then
SetWindowLong lHwnd, GWL_STYLE, style Or WS_CAPTION
Else
SetWindowLong lHwnd, GWL_STYLE, style And Not WS_CAPTION
End If
SetWindowPos lHwnd, 0, vrWin.Left, vrWin.Top, vrWin.Right - vrWin.Left, _
vrWin.Bottom - vrWin.Top, SWP_FRAMECHANGED
End Sub
