copie et remplissage tableau

[alessandro]

Bonjour tout le monde, je débute en VBA et voici mon pb:
J'ai un tableau rempli totalement avec des cellules pleines et des cellules vides. les pleines sont des X
Je voudrai créer une macro qui parcours ce tableau et chaque fois qu'elle rencontre une cellule avec X elle me fasse une copie des 3 premières cellules comprises sur la même ligne dans une nouvelle feuille + copier le nombre de colonne active
qui correspone a la semaine de visite.
piece jointe pour voir ce que je voudrai
merci
Alessandro

 

[Sheldor]

Re : copie et remplissage tableau

bonjour
j'ai du code "généraliste" pour ce genre de situation qui revient souvent, généraliste: ça fonctionne quelle que soit le nb de lignes et/ou col d'infos relatives aux data du table
il faut se placer sur la cellule en haut à gauche du tableau contenant les données (D3) dans ton cas

à adapter
à+

With Selection.Interior
.ColorIndex = 4
.Pattern = xlSolid
End With

t1 = Now


With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False


Application.ScreenUpdating = False


feuille_source = ActiveSheet.Name

Sheets.Add

nouvelle_feuille = ActiveSheet.Name

Sheets(feuille_source).Select

'sélectionner la première donnée

ligne = ActiveCell.Row
colonne = ActiveCell.Column


nb_lignes = ligne - 1
nb_colonne = colonne - 1

'nb total de colonnes
n1 = 0
For i = 1 To nb_lignes
n2 = Cells(i, 255).End(xlToLeft).Column
If n2 > n1 Then n1 = n2
Next i

nb_total_colonne = n1 - nb_colonne


'nb total de lignes
n1 = 0
For i = 1 To nb_colonne
n2 = Cells(65536, i).End(xlUp).Row
If n2 > n1 Then n1 = n2
Next i

nb_total_ligne = n1 - nb_lignes


'''''''''''''''''''''''''''''''''''''''''''''''''''
compteur = 1
'''''''''''''''''''''''''''''''''''''''''''''''''''

'boucle avançant sur les colonnes

For maligne = ligne To nb_total_ligne + nb_lignes
'maligne = ligne

For a = colonne To nb_total_colonne + nb_colonne

If Cells(maligne, a) <> 0 And Cells(maligne, a) <> "" Then

For boucle = 1 To nb_colonne
Sheets(nouvelle_feuille).Cells(compteur, boucle) = Cells(maligne, boucle)
Next boucle
For boucle2 = 1 To nb_lignes
Sheets(nouvelle_feuille).Cells(compteur, boucle2 + nb_colonne) = Cells(boucle2, a) 'boucle)
Next boucle2

Sheets(nouvelle_feuille).Cells(compteur, nb_colonne + nb_lignes + 1) = Cells(maligne, a)


compteur = compteur + 1

End If





Next a
'r = Range("A65536").End(xlUp).Row + 1
'c= Range("IV1").End(xlToLeft).Column

Next maligne


Sheets(nouvelle_feuille).Select

With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False

t = Int((Now - t1) * 24 * 3600 * 10) / 10

 

[pierrejean]

Re : copie et remplissage tableau

Bonjour alessandro

Vois si cela te convient

Edit : Salut Nicopec

 

[job75]

Re : copie et remplissage tableau

Bonjour alessandro, nicopec, Pierre,

Dans le code de la feuille "Foglio2" :

Private Sub Worksheet_Activate()
Dim P As Range, t, ncol%, rest(), n&, i&, j%
With Foglio1 'CodeName, à adapter
  Set P = .Range("A2:BC" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
t = P 'matrice, plus rapide
ncol = UBound(t, 2)
ReDim rest(1 To 2 * Application.CountIf(P.Offset(, 3), "X") + 1, 1 To 4)
n = -1
For i = 2 To UBound(t)
  For j = 4 To ncol
    If t(i, j) = "X" Then
      n = n + 2
      rest(n, 1) = t(i, 1): rest(n, 2) = t(i, 2): rest(n, 3) = t(i, 3)
      rest(n, 4) = t(1, j)
    End If
Next j, i
If n > 0 Then [A2].Resize(n, 4) = rest
Range("A" & n + 3 & ":D" & Rows.Count).Delete xlUp
End Sub

La macro se déclenche quand on active la feuille.

Fichier joint.

A+

 

[alessandro]

Re : copie et remplissage tableau

Bonjour
merci pour votre reponse
amicalment
Alessandro