Microsoft 365 Copier les données d'une feuille à une autre

[mimich_88]

Bonjour,

J'ai écrit une fonction qui copie des données d'une feuille à une autre. Dans la première feuille j'ai 3 colonnes de 3 règles différentes (Completness, Accuracy, Validity) mais dans la deuxième feuille je veux collecter ces règles dans une seule colonne et mettre le type de chaque règle devant (voir photo, la feuille SOURCE c'est ce que j'ai et la feuille COPY c'est ce que je veux avoir)

Function columnLookup(Name As String, Line As Range) As Integer
Dim i As Integer
Dim Cell As Range
 
i = 0
For Each Cell In Line
    If Cell.Value = Name Then
        i = Cell.Column
    End If
Next Cell
 
columnLookup = i
End Function
 
Sub CopyfromSource()
 
 
    Dim k As Variant
    Dim localworksheet, globalWorksheet As String
    Dim currentLine, currentLine1 As Integer
    Dim classeur As Workbook
 
    Dim nameFile As String
 
 
    Dim headerSource As Range
    Dim headerCopy As Range
 
    Dim attributSource, attributCopy As Integer
 
 
    globalWorksheet = "Source"
    localworksheet = "Copy"
 
 
    Worksheets(globalWorksheet).Activate
 
    Set headerSource = Worksheets(globalWorksheet).Range("A1", Worksheets(globalWorksheet).Range("A1").End(xlToRight))
    Set headerCopy = Worksheets(localworksheet).Range("A1", Worksheets(localworksheet).Range("A1").End(xlToRight))
 
 
    attributSource = columnLookup("Attribute", headerSource)
    attributCopy = columnLookup("Attribute", headerCopy)
 
 
    'Copy
 
    currentLine1 = 2
 
    For k = 2 To 10
 
 
        Worksheets(localworksheet).Cells(currentLine1, attributCopy).Value = Worksheets(globalWorksheet).Cells(k, attributSource).Value
 
        currentLine1 = currentLine1 + 1
 
    Next k
 
 
    Worksheets(localworksheet).Activate
 
 
    ActiveSheet.Copy
 
 
End Sub

 

[djidji59430]

Bonjour à tous,

Avec PowerQuery

 

[mimich_88]

Bonjour à tous,

Avec PowerQuery

Merci c'est très gentil mais malheureusement il me le faut avec VBA

 

[soan]

Bonjour mimich, djidji,

bienvenue sur le site XLD !

ton fichier en retour ; regarde d'abord la 2ème feuille "Copy" ;
va sur la feuille "Source" ; fais Ctrl e ➯ travail effectué !

---

code VBA (28 lignes) :

Option Explicit

Sub CpyData()
  If ActiveSheet.Name <> "Source" Then Exit Sub
  Dim dlg&: dlg = Cells(Rows.Count, 1).End(3).Row
  If dlg = 1 Then Exit Sub
  Dim Attr$, chn$, lg1&, lg2&, col As Byte
  lg2 = 2: Application.ScreenUpdating = 0
  With Worksheets("Copy")
    .Columns("A:C").ClearContents: .[B1] = "Rule"
    .[A1] = "Attributes": .[C1] = "Rule Type"
    For lg1 = 2 To dlg
      Attr = Cells(lg1, 1)
      If Attr <> "" Then
        For col = 2 To 4
          chn = Cells(lg1, col)
          If chn <> "" Then
            With .Cells(lg2, 1)
              .Value = Attr: .Offset(, 1) = chn: chn = Cells(1, col)
              .Offset(, 2) = Right$(chn, Len(chn) - 5): lg2 = lg2 + 1
            End With
          End If
        Next col
      End If
    Next lg1
    .Select
  End With
End Sub

soan

 

[Jean-Eric]

Bonsoir,
Une autre proposition VBA.
Cdlt.

Public Sub TransposeData()
Dim ws As Worksheet, ws2 As Worksheet, tbl As Variant, arr() As Variant, I As Long, J As Long, k As Long

    Set ws = Worksheets("Source"): Set ws2 = Worksheets("Copy")

    tbl = ws.Cells(1).CurrentRegion.Value2
    For I = 2 To UBound(tbl)
        For J = 2 To UBound(tbl, 2)
            If tbl(I, J) <> "" Then
                ReDim Preserve arr(3, k + 1)
                arr(0, k) = tbl(I, 1)
                arr(1, k) = tbl(I, J)
                arr(2, k) = Replace(tbl(1, J), "Rule ", "")
                k = k + 1
            End If
        Next J
    Next I

    With ws2
        .Cells(1).CurrentRegion.ClearContents
        If k > 0 Then
            .Cells(1).Resize(, 3).Value = Array("Attibute", "Rule", "Rule type")
            .Cells(2, 1).Resize(k, 3).Value = Application.Transpose(arr)
            .Activate
            .Cells(1).Select
        End If
    End With
   
End Sub

 

[mimich_88]

Bonjour mimich, djidji,

bienvenue sur le site XLD !

ton fichier en retour ; regarde d'abord la 2ème feuille "Copy" ;
va sur la feuille "Source" ; fais Ctrl e ➯ travail effectué !

---

code VBA (28 lignes) :

Option Explicit

Sub CpyData()
  If ActiveSheet.Name <> "Source" Then Exit Sub
  Dim dlg&: dlg = Cells(Rows.Count, 1).End(3).Row
  If dlg = 1 Then Exit Sub
  Dim Attr$, chn$, lg1&, lg2&, col As Byte
  lg2 = 2: Application.ScreenUpdating = 0
  With Worksheets("Copy")
    .Columns("A:C").ClearContents: .[B1] = "Rule"
    .[A1] = "Attributes": .[C1] = "Rule Type"
    For lg1 = 2 To dlg
      Attr = Cells(lg1, 1)
      If Attr <> "" Then
        For col = 2 To 4
          chn = Cells(lg1, col)
          If chn <> "" Then
            With .Cells(lg2, 1)
              .Value = Attr: .Offset(, 1) = chn: chn = Cells(1, col)
              .Offset(, 2) = Right$(chn, Len(chn) - 5): lg2 = lg2 + 1
            End With
          End If
        Next col
      End If
    Next lg1
    .Select
  End With
End Sub

soan

ça fonctionne merci énormément

 

[mimich_88]

Bonsoir,
Une autre proposition VBA.
Cdlt.

Public Sub TransposeData()
Dim ws As Worksheet, ws2 As Worksheet, tbl As Variant, arr() As Variant, I As Long, J As Long, k As Long

    Set ws = Worksheets("Source"): Set ws2 = Worksheets("Copy")

    tbl = ws.Cells(1).CurrentRegion.Value2
    For I = 2 To UBound(tbl)
        For J = 2 To UBound(tbl, 2)
            If tbl(I, J) <> "" Then
                ReDim Preserve arr(3, k + 1)
                arr(0, k) = tbl(I, 1)
                arr(1, k) = tbl(I, J)
                arr(2, k) = Replace(tbl(1, J), "Rule ", "")
                k = k + 1
            End If
        Next J
    Next I

    With ws2
        .Cells(1).CurrentRegion.ClearContents
        If k > 0 Then
            .Cells(1).Resize(, 3).Value = Array("Attibute", "Rule", "Rule type")
            .Cells(2, 1).Resize(k, 3).Value = Application.Transpose(arr)
            .Activate
            .Cells(1).Select
        End If
    End With
  
End Sub

Merci beaucoup pour ton aide