Copier des données à partir d'une feuille excel à une autre (complexe) à l'aide de VBA basé sur le nom de la colonne

Je suis très nouveau pour VBA et après 5 heures de visionnage de vidéos et de Googler, je pense que c'est juste trop au-dessus de ma tête... toute aide est très appréciée.

Donc, j'ai 2 feuilles de calcul excel: Feuil1 et Feuil2. J'ai un O/N de la colonne dans la feuille "Sheet1" et si la colonne = "Y" alors je veux copier toutes les données de la ligne qui correspond à un nom de colonne dans la Feuil2.

Sheet1
Product     Price     SalesPerson    Date    Commission     Y/N
  A          $25         John       1/9/15      $3           Y 
  B          $20         John       1/12/15     $2           N  
  B          $15         Brad       1/5/15      $1           Y

Sheet2
Price     Product     Date     Salesperson

Ainsi, pour chaque temps Y/N = Y puis copier les données qui correspond plus à feuil2 et cela jusqu'à ce que la feuille sheet1.col1 est nulle (en boucle). Le résultat serait celui-ci:

Sheet2
Price     Product     Date     Salesperson
 $25         A       1/9/15        John
 $15         B       1/5/15        Brad

Les colonnes ne sont pas dans l'ordre et sont bien trop nombreux pour entrer manuellement. Puis en dernier, mais pas moins l'O/N colonne devra clair sur terminer. J'ai essayé de modifier ce avec pas de chance:

Sub CopyHeaders()
Dim header As Range, headers As Range
Set headers = Worksheets("Sheet1").Range("A1:Z1")

For Each header In headers
    If GetHeaderColumn(header.Value) > 0 Then
        Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("Sheet2").Cells(2, GetHeaderColumn(header.Value)).End(xlDown).Offset(1, 0)
    End If
Next
End Sub

Function GetHeaderColumn(header As String) As Integer
Dim headers As Range
Set headers = Worksheets("Sheet2").Range("A1:Z1")
GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function

Ceci a été conçu pour faire quelque chose de différent que ce que je suis en train de faire et je ne pense pas que je suis capable de changer cela fonctionne pour moi. Comment wold-je faire cela?

Je vais faire plus de recherche et de mise à jour, mais je n'ai pas été en mesure d'obtenir ce code fonctionne... probablement en raison de la feuil2 contenant des colonnes qui ne sont pas dans la feuille sheet1

InformationsquelleAutor user3486773 | 2015-01-20

Bien, maintenant, il fonctionne aussi si vous avez des colonnes dans la feuille Sheet2 qui n'existent pas dans la feuille Sheet1.

Sous CopySheet()
Dim i as Integer
Dim LastRow As Integer
Dim De Recherche Comme Une Chaîne De Caractères
Dim Colonne Integer

Sheets("Sheet1").Activate
Sheets("Sheet1").Range("A1").Select
'Sets an Autofilter to sort out only your Yes rows.
Selection.Autofilter
'Change Field:=5 to the number of the column with your Y/N.
Sheets("Sheet1").Range("$A$1:$G$3").Autofilter Field:=7, Criteria1:="Y"

'Finds the last row
LastRow = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, "A").End(xlUp).Row

i = 1
'Change the 3 to the number of columns you got in Sheet2
Do While i <= 3
    Search = Sheets("Sheet2").Cells(1, i).Value
    Sheets("Sheet1").Activate
    'Update the Range to cover all your Columns in Sheet1.
    If IsError(Application.Match(Search, Sheets("sheet1").Range("A1:G1"), 0)) Then
        'nothing
    Else
        Column = Application.Match(Search, Sheets("sheet1").Range("A1:G1"), 0)
        Sheets("Sheet1").Cells(2, Column).Resize(LastRow, 1).Select
        Selection.Copy
        Sheets("Sheet2").Activate
        Sheets("Sheet2").Cells(2, i).Select
        ActiveSheet.Paste
    End If
    i = i + 1
Loop

'Clear all Y/N = Y
'Update the Range to cover all your Columns in Sheet1.
Sheets("Sheet1").Activate
Column = Application.Match("Y/N", Sheets("sheet1").Range("A1:G1"), 0)
Sheets("Sheet1").Cells(2, Column).Resize(LastRow, 1).Select
Selection.ClearContents
End Sub

Donc, mon feuil2 n'avez colonnes qui ne sont pas dans la feuille sheet1 🙁
Changé de travail, même si il y a de colonnes dans la feuille sheet2 qui n'existe pas dans la feuille sheet1.

InformationsquelleAutor Marvin

Vous pouvez l'essayer aussi, à condition que les colonnes sont comme vous l'avez mentionné ci-dessus (de A à F dans la feuille "sheet1" et A à D dans la feuil2).

Sub copies()
    Dim i, j, row As Integer
    j = Worksheets("sheet1").Range("A1").End(xlDown).row
    For i = 1 To j
        If Cells(i, 6) = "Y" Then _
        row = Worksheets("sheet2").Range("A1").End(xlDown).row + 1
        Worksheets("sheet2").Cells(row, 1) = Worksheets("sheet1").Cells(i, 2)
        Worksheets("sheet2").Cells(row, 2) = Worksheets("sheet1").Cells(i, 1)
        Worksheets("sheet2").Cells(row, 3) = Worksheets("sheet1").Cells(i, 4)
        Worksheets("sheet2").Cells(row, 4) = Worksheets("sheet1").Cells(i, 3)
    Next
    Worksheets("sheet1").Range("F:F").ClearContents
End Sub

InformationsquelleAutor dimitris

Lors de la recherche de cette nouvelle, j'ai été à la recherche dans la création d'un tableau statique pour les en-têtes... puis user3561813 fourni ce bijou (j'ai modifié un peu pour mon instruction if et de la boucle à travers la feuille:

Sub validatetickets()

Do Until ActiveCell.Value = ""
If Cells(ActiveCell.Row, 43) = "Y" Then

Dim wsOrigin As Worksheet
Dim wsDest As Worksheet
Dim nCopyRow As Long
Dim nPasteRow As Long
Dim rngFnd As Range
Dim rngDestSearch As Range
Dim cel As Range

Const ORIGIN_ROW_HEADERS = 1
Const DEST_ROW_HEADERS = 1


Set wsOrigin = Sheets("Case")
Set wsDest = Sheets("Sheet1")

nCopyRow = ActiveCell.Row
nPasteRow = wsDest.Cells(Rows.Count, 1).End(xlUp).Row + 1

Set rngDestSearch = Intersect(wsDest.UsedRange, wsDest.Rows(DEST_ROW_HEADERS))

For Each cel In Intersect(wsOrigin.UsedRange, wsOrigin.Rows(ORIGIN_ROW_HEADERS))
On Error Resume Next
    Set rngFnd = rngDestSearch.Find(cel.Value)

    If rngFnd Is Nothing Then
        'Do Nothing as Header Does not Exist
    Else
        wsDest.Cells(nPasteRow, rngFnd.Column).Value = wsOrigin.Cells(nCopyRow, cel.Column).Value
    End If
On Error GoTo 0

Set rngFnd = Nothing
Next cel
ActiveCell.Offset(1, 0).Select
Else: ActiveCell.Offset(1, 0).Select
End If

Loop
End Sub

C'est plutôt astucieux de la façon dont il fonctionne et est très évolutive. Ne dépend pas de deux feuilles présentant des colonnes etc... je peux voir ce qui est très utile dans l'avenir. 🙂

InformationsquelleAutor user3486773

Vous devez vous connecter pour publier un commentaire.