Copier coller selon un encadrement variable

[pascal82]

Bonjour à tous,

Une partie de mon programme est terminée par contre je n'arrive pas à réaliser:

- Copie de la colonne L de la feuille 1 en respectant l'encadrement défini par les variables i et j vers la colonne B de la feuille 2
- Suppression des lignes vides (Programme joint)
- Copier transposer les 10 premiers résultats de la colonne B feuille 2 vers la feuille 1 en colonne AA incrémentée selon la variable h

L'objectif est de copier les premiers résultats dans l'ordre d'apparition. C'est une méthode que j'ai choisi, par contre s'il est possible de faire autrement aucun problème

Je ne suis pas sur que tout soit bien clair, c'est pourquoi j'ai mis les résultats attendus dans le tableau AA2:AJ15

Cordialement

 

[pascal82]

Re : Copier coller selon un encadrement variable

Bonsoir,

Je n'ai certainement pas été très explicite dans ma demande initiale parce que pas de réponse.
J'ai réalisé un petit code (même s'il n'est pas des plus beau) qui corresponde à ma demande.
Je le joins au cas ou une personne aurait mieux.

Cordialement

Option Explicit

Sub StsBar(ByVal strMsg As String)
    Application.StatusBar = strMsg
End Sub

Sub traitement()

Dim h As Long, i As Long, j As Long
Dim strOps As String, strFormuleA As String
Application.ScreenUpdating = False
Sheets("1").Activate
Range("N2:AK50").ClearContents
    
    strFormuleA = "=IF(AND(RC[-11]=R1C[2],RC[-10]=R1C[3],RC[-9]=R1C[4],RC[-8]=R1C[5],RC[-7]=R1C[6],RC[-6]=R1C[7],RC[-5]=R1C[8],RC[-4]=R1C[9],RC[-3]=R1C[10]),RC[-1],"""")"
    Range("L2:L50").FormulaR1C1 = strFormuleA

    For h = 0 To 13
    Sheets("1").Activate
    Range("N1:W1").Value = Range("A2:J2").Offset(h, 0).Value 'copie des données
    If h >= 0 And h < 5 Then i = 6
    If h > 4 And h < 10 Then i = 11
    If h > 9 And h < 15 Then i = 16
    j = i + 33
    StsBar strOps & "  h=" & h & "  i=" & i & "  j=" & j
    Range("X1").Value = "=COUNTIF(R[" & i & "]C[-12]:R[" & j & "]C[-12],0)"
    Range("Y1").Value = "=COUNTIF(R[" & i & "]C[-13]:R[" & j & "]C[-13],1)"
    Range("N2:Y2").Offset(h, 0).Value = Range("N1:Y1").Value 'copie des résultats
    
Sheets("1").Range(Cells(i, 12), Cells(j, 12)).Copy
Sheets("2").Range("B1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    supLignesRapide
    
Sheets("2").Range("B2:B11").Copy 'copie resultat feuille 2
Sheets("1").Range("AA2").Offset(h, 0).PasteSpecial xlPasteValues, , , True

    Next

ActiveWorkbook.Save
Application.ScreenUpdating = True
End Sub


Sub supLignesRapide() 'suppression de lignes tres rapide
'supprime les lignes contenant "B" en colonne A
 Dim c As Range
 Dim strFormuleA As String
 Sheets("2").Activate
     strFormuleA = "=IF(RC[1]="""",""B"","""")"
    Range("A2:A170").FormulaR1C1 = strFormuleA
 With ActiveSheet
     .Range("A1").CurrentRegion.Sort key1:=.Cells(2, 1), Order1:=xlAscending, Header:=xlYes
     Set c = .Columns(1).Find(What:="B", LookIn:=xlValues)
     If Not c Is Nothing Then
         .Range(c, .Cells(.Rows.Count, 1).End(xlUp)).EntireRow.Delete xlShiftUp
     End If
 End With
 End Sub