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

mimich_88 · 22 Juin 2022

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)

VB:

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 · 22 Juin 2022

Bonjour à tous,

Avec PowerQuery

mimich_88 · 22 Juin 2022

djidji59430 à dit:
Bonjour à tous,

Avec PowerQuery

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

soan · 22 Juin 2022

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) :

VB:

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 · 22 Juin 2022

Bonsoir,
Une autre proposition VBA.
Cdlt.

VB:

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 · 23 Juin 2022

soan à dit:

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) :

VB:

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 · 23 Juin 2022

Jean-Eric à dit:

Bonsoir,
Une autre proposition VBA.
Cdlt.

VB:

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

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

mimich_88

XLDnaute Nouveau

djidji59430

XLDnaute Barbatruc

Pièces jointes

mimich_88

XLDnaute Nouveau

soan

XLDnaute Barbatruc

Pièces jointes

Jean-Eric

XLDnaute Occasionnel

Pièces jointes

mimich_88

XLDnaute Nouveau

mimich_88

XLDnaute Nouveau

Discussions similaires