Problème d'automatisatiion

[constybauer]

Slt àtous.je débute en programmation et j'ai un souci avec l'automatisation d'un fihier excel.Je doit parcourir des cellule d'une plage et prendre les infos contenues dans les cellules pour les automatiser dans un tableau de cellules.Je joint le fichier excel pour que vous compreniez plus.
Merci de lire ce message et je suis en attente d'une solution

 

[PMO2]

Re : Problème d'automatisatiion

Bonjour,

Voici une piste en VBA.

Copiez le code suivant dans un module standard

'### Constantes à adapter selon votre usage ###
Const FEUILLE As String = "test"
Const CELLULE_DEPART As String = "a2"
'##############################################

Sub DateDebit2Tableau()
Dim S As Worksheet
Dim R As Range
Dim var
Dim i&
Dim j&
Dim cpt&
Dim T()
Dim Titres
Titres = Array("debit", "date_debut", "", "date_fin")
On Error Resume Next
Set S = ActiveWorkbook.Sheets(FEUILLE)
If Err <> 0 Then
  MsgBox "La feuille ''" & FEUILLE & "'' est introuvable."
  Exit Sub
End If
On Error GoTo 0
Set R = S.Range(CELLULE_DEPART).CurrentRegion
var = R.Value
If UBound(var, 2) > 256 Then
  MsgBox "La plage ''Date - Débit'' est limitée à 255 colonnes.", _
    Title:="Limitez à 255 colonnes"
  Exit Sub
End If
For j& = 2 To UBound(var, 2)
  If IsEmpty(var(1, j&)) Or Not IsDate(var(1, j&)) Then
    S.Activate
    S.Range(S.Cells(2, j&), S.Cells(2, j&)).Select
    MsgBox "La cellule n'est pas une date."
    Exit Sub
  End If
  If IsEmpty(var(2, j&)) Or Not IsNumeric(var(2, j&)) Then
    S.Activate
    S.Range(S.Cells(3, j&), S.Cells(3, j&)).Select
    MsgBox "La cellule n'est pas un nombre."
    Exit Sub
  End If
Next j&
cpt& = 1
ReDim Preserve T(1 To 4, 1 To cpt&)
T(1, cpt&) = var(2, 2)
T(2, cpt&) = CLng(var(1, 2))
T(4, cpt&) = T(2, cpt&) 'par défaut - temporaire
For j& = 3 To UBound(var, 2)
  If var(2, j&) <> var(2, j& - 1) Then
    cpt& = cpt& + 1
    T(4, cpt& - 1) = CLng(var(1, j& - 1))
    ReDim Preserve T(1 To 4, 1 To cpt&)
    T(1, cpt&) = var(2, j&)
    T(2, cpt&) = CLng(var(1, j&))
    T(4, cpt&) = T(2, cpt&) 'par défaut - temporaire
  End If
  If j& = UBound(var, 2) Then
    T(4, cpt&) = CLng(var(1, j&))
  End If
Next j&
Application.ScreenUpdating = False
On Error GoTo Erreur
Set S = Sheets.Add
Set R = S.Range(S.Cells(1, 1), S.Cells(UBound(T, 2), UBound(T, 1)))
R = Application.WorksheetFunction.Transpose(T)
For i& = xlEdgeLeft To xlInsideVertical
  R.Borders(i&).LineStyle = xlContinuous
Next i&
Set R = Application.Union(S.Range(S.Cells(1, 2), S.Cells(UBound(T, 2), 2)), _
      S.Range(S.Cells(1, 4), S.Cells(UBound(T, 2), 4)))
R.NumberFormat = "m/d/yyyy"
Set R = S.Range(S.Cells(1, 3), S.Cells(UBound(T, 2), 3))
R = "au"
R.HorizontalAlignment = xlCenter
Rows(1).Insert
Set R = S.Range(S.Cells(1, 1), S.Cells(1, UBound(T, 1)))
R = Titres
R.Font.Bold = True
R.HorizontalAlignment = xlCenter
Erreur:
Application.ScreenUpdating = True
If Err <> 0 Then MsgBox "Erreur : " & Err.Number & vbCrLf & Err.Description
End Sub

Il vous faut adapter, à votre usage, les constantes cernées par des dièses (###). M'étant référé à votre exemple, il n'y a peut-être rien à changer ???

Lancez la macro "DateDebit2Tableau" qui va créer une nouvelle feuille dans laquelle s'incrira le résultat.

Cordialement.

PMO
Patrick Morange

 

[Catrice]

Re : Problème d'automatisatiion

Bonjour,

ci-joint une autre approche.