Boostez vos compétences Excel avec notre communauté !
Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !
Sub CtrlPrix()
Dim C As Range
Dim DecSep$
Dim x#
DecSep$ = Application.International(xlDecimalSeparator)
Sheets(CONTROLE).Range("B14:IV14").Clear
With Sheets(DATA)
For Each C In .Range("AH2", .[AH65536].End(xlUp)).SpecialCells(xlCellTypeConstants)
If DecSep$ = "." Then
C.Replace ",", DecSep$
ElseIf DecSep$ = "," Then
C.Replace ".", DecSep$
End If
C = C.Value '******28/01/09******
C.NumberFormat = "0.00"
If IsNumeric(C) Then
C.HorizontalAlignment = xlRight '******28/01/09******
'--- Détection des nombres avec plus de 2 décimales ---
x# = C
If CDbl(CLng(x# * 100) / 100) <> x# Then
C.NumberFormat = "General"
Sheets(CONTROLE).Range("IV14").End(xlToLeft).Offset(0, 1).Value = C.Address(REF_ABS, REF_ABS)
End If
'------------------------------------------------------
Else
Sheets(CONTROLE).Range("IV14").End(xlToLeft).Offset(0, 1).Value = C.Address(REF_ABS, REF_ABS)
End If
Next C
End With
Call CleanImages
End Sub
Sub CtrlPrix()
Dim C As Range
Dim DecSep$
Dim x#
DecSep$ = Application.International(xlDecimalSeparator)
Sheets(CONTROLE).Range("B14:IV14").Clear
With Sheets(DATA)
For Each C In .Range("AH2", .[AH65536].End(xlUp)).SpecialCells(xlCellTypeConstants)
If DecSep$ = "." Then
C.Replace ",", DecSep$
ElseIf DecSep$ = "," Then
C.Replace ".", DecSep$
End If
C = C.Value '******28/01/09******
C.NumberFormat = "0.00"
If IsNumeric(C) Then
C.HorizontalAlignment = xlRight '******28/01/09******
'--- Détection des nombres avec plus de 2 décimales ---
x# = C
If CDbl(CLng(x# * 100) / 100) <> x# Then
C.NumberFormat = "General"
Sheets(CONTROLE).Range("IV14").End(xlToLeft).Offset(0, 1).Value = C.Address(REF_ABS, REF_ABS)
End If
'------------------------------------------------------
Else
Sheets(CONTROLE).Range("IV14").End(xlToLeft).Offset(0, 1).Value = C.Address(REF_ABS, REF_ABS)
End If
Next C
End With
Call CleanImages
End Sub
Private Declare Function GetLocaleInfo& Lib "kernel32" Alias "GetLocaleInfoA" _
(ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, _
ByVal cchData As Long)
Private Declare Function GetSystemDefaultLCID& Lib "kernel32" ()
Sub CtrlPrix() 'Contrôle Format Prix
Dim R As Range
Dim C As Range
Dim DecSep$
Dim x#
Dim SystemSeparator$
Dim tampon$
Dim LenTampon&
With Application
If Application.UseSystemSeparators Then
tampon$ = Space(255)
LenTampon& = GetLocaleInfo(GetSystemDefaultLCID, &HE, tampon$, 255)
DecSep$ = Left$(tampon$, LenTampon& - 1)
Else
DecSep$ = Application.International(xlDecimalSeparator)
End If
End With
Sheets(CONTROLE).Range("B14:IV14").Clear
With Sheets(DATA)
Set R = .Range("AH2", .[AH65536].End(xlUp))
For Each C In R
If DecSep$ = "." Then
C.Replace ",", DecSep$
ElseIf DecSep$ = "," Then
C.Replace ".", DecSep$
End If
C = C.Value '******28/01/09******
C.NumberFormat = "0.00"
If IsNumeric(C) Then
C.HorizontalAlignment = xlRight '******28/01/09******
C = CDbl(C)
'--- Détection des nombres avec plus de 2 décimales ---
x# = C
If CDbl(CLng(x# * 100) / 100) <> x# Then
C.NumberFormat = "General"
Sheets(CONTROLE).Range("IV14").End(xlToLeft).Offset(0, 1).Value = C.Address(REF_ABS, REF_ABS)
End If
'------------------------------------------------------
Else
Sheets(CONTROLE).Range("IV14").End(xlToLeft).Offset(0, 1).Value = C.Address(REF_ABS, REF_ABS)
End If
Next C
End With
Call CleanImages
End Sub
If Application.UseSystemSeparators Then
Private Declare Function GetLocaleInfo& Lib "kernel32" Alias "GetLocaleInfoA" _
(ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, _
ByVal cchData As Long)
Private Declare Function GetSystemDefaultLCID& Lib "kernel32" ()
Sub CtrlPrix() 'Contrôle Format Prix
Dim R As Range
Dim C As Range
Dim DecSep$
Dim x#
Dim SystemSeparator$
Dim tampon$
Dim LenTampon&
With Application
If Application.UseSystemSeparators Then
tampon$ = Space(255)
LenTampon& = GetLocaleInfo(GetSystemDefaultLCID, &HE, tampon$, 255)
DecSep$ = Left$(tampon$, LenTampon& - 1)
Else
DecSep$ = Application.International(xlDecimalSeparator)
End If
End With
Sheets(CONTROLE).Range("B14:IV14").Clear
With Sheets(DATA)
Set R = .Range("AH2", .[AH65536].End(xlUp))
For Each C In R
If DecSep$ = "." Then
C.Replace ",", DecSep$
ElseIf DecSep$ = "," Then
C.Replace ".", DecSep$
End If
C = C.Value '******28/01/09******
C.NumberFormat = "0.00"
If IsNumeric(C) Then
C.HorizontalAlignment = xlRight '******28/01/09******
C = CDbl(C)
'--- Détection des nombres avec plus de 2 décimales ---
x# = C
If CDbl(CLng(x# * 100) / 100) <> x# Then
C.NumberFormat = "General"
Sheets(CONTROLE).Range("IV14").End(xlToLeft).Offset(0, 1).Value = C.Address(REF_ABS, REF_ABS)
End If
'------------------------------------------------------
Else
Sheets(CONTROLE).Range("IV14").End(xlToLeft).Offset(0, 1).Value = C.Address(REF_ABS, REF_ABS)
End If
Next C
End With
Call CleanImages
End Sub
Set R = S.Range(S.Cells(16, 2), S.Cells(16, UBound(T, 2) + 1))
Sub CleanImages() 'Contrôle Format Images
Dim var
Dim R As Range
Dim S As Worksheet
Dim i&
Dim cpt&
Dim A$
Dim Ref$
Dim bool As Boolean
Dim T()
Set S = ActiveWorkbook.Sheets(DATA)
Set R = S.Range(S.Cells(1, 1), S.Cells(S.[bd65536].End(xlUp).Row, 56))
var = R
For i& = 2 To UBound(var, 1)
bool = False
A$ = var(i&, 56) 'commodité d'écriture
If A$ <> "" Then
If LCase(Right(A$, 4)) <> ".jpg" And _
LCase(Right(A$, 4)) <> ".gif" Then bool = True
If Left(A$, Len(Trim(var(i&, 1)))) <> Trim(var(i&, 1)) Then bool = True
If var(i&, 1) = "" Then bool = True
If InStr(1, A$, Chr(160)) Then bool = True
If InStr(1, A$, Space(1)) Then bool = True
If InStr(1, A$, "_") = 0 Then bool = True
If bool Then
cpt& = cpt& + 1
ReDim Preserve T(1 To 1, 1 To cpt&)
If REF_ABS Then
Ref$ = "$BD$"
Else
Ref$ = "BD"
End If
T(1, cpt&) = Ref$ & i&
End If
End If
Next i&
Set S = ActiveWorkbook.Sheets(CONTROLE)
S.Range("b16:iv16").ClearContents
If cpt& > 0 Then '///ajout 26/01/09
Set R = S.Range(S.Cells(16, 2), S.Cells(16, UBound(T, 2) + 1))
R = T
End If '///ajout 26/01/09
Call ctrl_form
End Sub
Sub CleanImages() 'Contrôle Format Images
Dim var
Dim R As Range
Dim S As Worksheet
Dim i&
Dim cpt&
Dim A$
Dim Ref$
Dim bool As Boolean
Dim T()
Set S = ActiveWorkbook.Sheets(DATA)
Set R = S.Range(S.Cells(1, 1), S.Cells(S.[bd65536].End(xlUp).Row, 56))
var = R
For i& = 2 To UBound(var, 1)
bool = False
A$ = var(i&, 56) 'commodité d'écriture
If A$ <> "" Then
If LCase(Right(A$, 4)) <> ".jpg" And _
LCase(Right(A$, 4)) <> ".gif" Then bool = True
If Left(A$, Len(Trim(var(i&, 1)))) <> Trim(var(i&, 1)) Then bool = True
If var(i&, 1) = "" Then bool = True
If InStr(1, A$, Chr(160)) Then bool = True
If InStr(1, A$, Space(1)) Then bool = True
If InStr(1, A$, "_") = 0 Then bool = True
If bool Then
cpt& = cpt& + 1
ReDim Preserve T(1 To 1, 1 To cpt&)
If REF_ABS Then
Ref$ = "$BD$"
Else
Ref$ = "BD"
End If
T(1, cpt&) = Ref$ & i&
End If
End If
Next i&
Set S = ActiveWorkbook.Sheets(CONTROLE)
S.Range("b16:iv16").ClearContents
[COLOR="Red"]
'--- Test de dépassement du nombre autorisé de colonnes ---
MsgBox "Nombre d'erreurs = " & cpt& & vbCrLf & _
"Nombre limite de colonnes Excel = " & Application.Columns.Count
'----------------------------------------------------------
[/COLOR]
If cpt& > 0 Then '///ajout 26/01/09
Set R = S.Range(S.Cells(16, 2), S.Cells(16, UBound(T, 2) + 1))
R = T
End If '///ajout 26/01/09
Call ctrl_form
End Sub
Sub CleanImages() 'Contrôle Format Images
Dim var
Dim R As Range
Dim S As Worksheet
Dim i&
Dim cpt&
Dim A$
Dim Ref$
Dim bool As Boolean
Dim T()
Set S = ActiveWorkbook.Sheets(DATA)
Set R = S.Range(S.Cells(1, 1), S.Cells(S.[bd65536].End(xlUp).Row, 56))
var = R
For i& = 2 To UBound(var, 1)
bool = False
A$ = var(i&, 56) 'commodité d'écriture
If A$ <> "" Then
If LCase(Right(A$, 4)) <> ".jpg" And _
LCase(Right(A$, 4)) <> ".gif" Then bool = True
If Left(A$, Len(Trim(var(i&, 1)))) <> Trim(var(i&, 1)) Then bool = True
If var(i&, 1) = "" Then bool = True
If InStr(1, A$, Chr(160)) Then bool = True
If InStr(1, A$, Space(1)) Then bool = True
If InStr(1, A$, "_") = 0 Then bool = True
If bool Then
cpt& = cpt& + 1
'--- Dépassement du nombre autorisé de colonnes ---
If cpt& > 254 Then
MsgBox cpt& & " erreurs ont été trouvées. Le programme ne peut en traiter plus." & vbCrLf & _
"Il vous faudra relancer le programme, après correction, pour voir s'il en subsiste d'autres"
End If
'--------------------------------------------------
ReDim Preserve T(1 To 1, 1 To cpt&)
If REF_ABS Then
Ref$ = "$BD$"
Else
Ref$ = "BD"
End If
T(1, cpt&) = Ref$ & i&
End If
End If
Next i&
Set S = ActiveWorkbook.Sheets(CONTROLE)
S.Range("b16:iv16").ClearContents
If cpt& > 0 Then '///ajout 26/01/09
Set R = S.Range(S.Cells(16, 2), S.Cells(16, UBound(T, 2) + 1))
R = T
End If '///ajout 26/01/09
Call ctrl_form
End Sub
Sub CleanImages() 'Contrôle Format Images
Dim var
Dim R As Range
Dim S As Worksheet
Dim i&
Dim cpt&
Dim A$
Dim Ref$
Dim bool As Boolean
Dim T()
Set S = ActiveWorkbook.Sheets(DATA)
Set R = S.Range(S.Cells(1, 1), S.Cells(S.[bd65536].End(xlUp).Row, 56))
var = R
For i& = 2 To UBound(var, 1)
bool = False
A$ = var(i&, 56) 'commodité d'écriture
If A$ <> "" Then
If LCase(Right(A$, 4)) <> ".jpg" And _
LCase(Right(A$, 4)) <> ".gif" Then bool = True
If Left(A$, Len(Trim(var(i&, 1)))) <> Trim(var(i&, 1)) Then bool = True
If var(i&, 1) = "" Then bool = True
If InStr(1, A$, Chr(160)) Then bool = True
If InStr(1, A$, Space(1)) Then bool = True
If InStr(1, A$, "_") = 0 Then bool = True
If bool Then
cpt& = cpt& + 1
'--- Dépassement du nombre autorisé de colonnes ---
If cpt& > 254 Then
MsgBox cpt& & " erreurs ont été trouvées. Le programme ne peut en traiter plus." & vbCrLf & _
"Il vous faudra relancer le programme, après correction, pour voir s'il en subsiste d'autres"
End If
'--------------------------------------------------
ReDim Preserve T(1 To 1, 1 To cpt&)
If REF_ABS Then
Ref$ = "$BD$"
Else
Ref$ = "BD"
End If
T(1, cpt&) = Ref$ & i&
End If
End If
Next i&
Set S = ActiveWorkbook.Sheets(CONTROLE)
S.Range("b16:iv16").ClearContents
If cpt& > 0 Then '///ajout 26/01/09
Set R = S.Range(S.Cells(16, 2), S.Cells(16, UBound(T, 2) + 1))
R = T
End If '///ajout 26/01/09
Call ctrl_form
End Sub
Sub CleanImages() 'Contrôle Format Images
Dim var
Dim R As Range
Dim S As Worksheet
Dim i&
Dim cpt&
Dim A$
Dim Ref$
Dim bool As Boolean
Dim T()
Set S = ActiveWorkbook.Sheets(DATA)
Set R = S.Range(S.Cells(1, 1), S.Cells(S.[bd65536].End(xlUp).Row, 56))
var = R
For i& = 2 To UBound(var, 1)
bool = False
A$ = var(i&, 56) 'commodité d'écriture
If A$ <> "" Then
If LCase(Right(A$, 4)) <> ".jpg" And _
LCase(Right(A$, 4)) <> ".gif" Then bool = True
If Left(A$, Len(Trim(var(i&, 1)))) <> Trim(var(i&, 1)) Then bool = True
If var(i&, 1) = "" Then bool = True
If InStr(1, A$, Chr(160)) Then bool = True
If InStr(1, A$, Space(1)) Then bool = True
If InStr(1, A$, "_") = 0 Then bool = True
If bool Then
cpt& = cpt& + 1
ReDim Preserve T(1 To 1, 1 To cpt&)
If REF_ABS Then
Ref$ = "$BD$"
Else
Ref$ = "BD"
End If
T(1, cpt&) = Ref$ & i&
End If
End If
Next i&
Set S = ActiveWorkbook.Sheets(CONTROLE)
S.Range("p12:p65536").ClearContents
Set R = S.Range("P12:P" & UBound(T, 2) + 12 - 1 & "")
R = WorksheetFunction.Transpose(T)
Call ctrl_form
End Sub
A quoi sert ce code ?
R = WorksheetFunction.Transpose(T)
If bool Then
cpt& = cpt& + 1
ReDim Preserve T(1 To 1, 1 To cpt&)
If REF_ABS Then
Ref$ = "$BD$"
Else
Ref$ = "BD"
End If
T(1, cpt&) = Ref$ & i&
End If
Set R = S.Range("P12:P" & UBound(T, 2) - 1 & "")
[COLOR="Blue"]
Set R = S.Range("P12:P" & UBound(T, 2) + 12 - 1 & "")
[/COLOR]
We use cookies and similar technologies for the following purposes:
Est ce que vous acceptez les cookies et ces technologies?
We use cookies and similar technologies for the following purposes:
Est ce que vous acceptez les cookies et ces technologies?