sheet1 sheet2

Le problème que je rencontre est que parfois des en-têtes et des valeurs de données entiers manquent dans l'ensemble de données et que, par conséquent, en utilisant la dernière ligne du script, les données sont décalées de un. Par exemple, si j'ai supprimé H11: H12 complètement sur la feuille 1, alors les valeurs de la colonne H associée à l'ensemble de données dans A11: K11 seront en fait de l'ensemble de données A13: K13 (ou valeur de cellule H14).

Les espaces affichés dans la deuxième image ne seraient pas présents si l'en-tête correspondant n'est pas présent.

Question: Compte tenu du code suivant; Pensez-vous qu'il est possible de faire correspondre les données aux en-têtes et d'utiliser le numéro de ligne de décalage d'origine à côté de la colonne à laquelle il correspond sur la feuille 2 et d'y coller les valeurs? Au lieu de cela, le code actuel (et la seule méthode qui a fonctionné était de trouver la dernière ligne).

Exemples / Réflexions: Je pense que le script devra prendre une cellule (telle que D9 et reconnaît que c'est un D et des décalages pour sélectionner D10 et faire correspondre cet enregistrement D9 à la feuille 2 colonne D et coller les données D10 dans D10 plutôt que D5.

Deuxième exemple, Script prend I17 et reconnaît qu'il correspond à I à la colonne I de la feuille 2, puis se décale pour sélectionner / copier et coller les données I19 dans I18 plutôt que I9.

Sub main()
    Dim hedaerCell As Range
    Dim labelsArray As Variant

    With ThisWorkbook.Worksheets("Sheet2") '<--| reference "headers" worksheet
        For Each hedaerCell In .Range("A1:K1") '<--| loop through all "headers"
            labelsArray = GetValues(hedaerCell.Value) '<--| fill array with all labels found under current "header"
            .Cells(.Rows.Count, hedaerCell.Column).End(xlUp).Offset(1).Resize(UBound(labelsArray)).Value = Application.Transpose(labelsArray)
            Next
    End With
End Sub

Function GetValues(header As String) As Variant
    Dim f As Range
    Dim firstAddress As String
    Dim iFound As Long

    With ThisWorkbook.Worksheets("Sheet1").UsedRange '<--| reference "data" worksheet
        ReDim labelsArray(1 To WorksheetFunction.CountIf(.Cells, header)) As Variant '<--| size an array to store as many "labels" as passed 'header' occurrences
        Set f = .Find(what:=header, LookIn:=xlValues, lookat:=xlWhole) '<--| start seraching for passed 'header'
        If Not f Is Nothing Then
            firstAddress = f.Address
            Do
                iFound = iFound + 1
                labelsArray(iFound) = f.Offset(1)
                Set f = .FindNext(f)
            Loop While f.Address <> firstAddress
        End If
    End With
    GetValues = labelsArray
End Function

Une addition: entrez la description de l'image ici

Il semble qu'il y ait une exception qui empêche la copie de ces valeurs de cellule.Si je le fais manuellement, la capture d'écran ci-dessous serait correcte. Des conseils à diagnostiquer?

enter image description here

Très étrange parce que la ligne avec le point rouge se copie bien dans les deux mais ces quatre lignes semblent échouer.

1
Ian Brigmann 17 janv. 2017 à 18:01

2 réponses

Meilleure réponse

Je laisse ma réponse précédente pour le bien de la postérité, mais maintenant que vous avez clarifié votre question, j'ai une meilleure réponse pour vous.

Je vais supposer ce qui suit: 1. toutes les deux lignes est une paire d'en-têtes / données; 2. les ensembles de paires de lignes peuvent être de longueur inégale car si un en-tête particulier est manquant pour une paire de lignes particulière, il n'y a pas de blanc car les en-têtes / données sont décalés vers la gauche; 3. il n'y aura pas de blancs dans les lignes d'en-tête jusqu'à la fin de la ligne 4. il peut y avoir des blancs dans la ligne de données 5. la sortie doit être tous les en-têtes (même s'il n'apparaît que sur 1 ligne) et les lignes des données, une par en-tête / paire de données dans la feuille d'origine.

Par exemple:

A|B|C|D|F|G|H|I  <--- some headers (missing E)
1|2|3|4|6|7|8|9  <--- data row 1
A|C|D|E|G|H|I    <--- some headers (missing B and F)
1|3|4|5|7|8|9    <--- data row 2

Est une feuille d'entrée valide et la feuille de sortie résultante serait:

A|B|C|D|E|F|G|H|I  <--- all headers
1|2|3|4| |6|7|8|9  <--- data row 1
1| |3|4|5| |7|8|9  <--- data row 2

Utilisez un Scripting.Dictionary de Scripting.Dictionarys pour suivre les paires d'en-têtes / données de lignes de longueur éventuellement différentes. Le Scripting.Dictionary des en-têtes vous permet d'ajouter de nouveaux en-têtes à mesure qu'ils apparaissent. Les Scripting.Dictionary imbriqués vous permettent de garder une trace uniquement des lignes qui ont une valeur pour un en-tête particulier, mais également de conserver le numéro de ligne pour plus tard.

Comme indiqué dans les commentaires, le code parcourt cette structure pour afficher TOUS les en-têtes et les données associées à chaque ligne. "((inputRow - 1) / 2)" calcule le numéro de ligne de sortie. Vous remarquerez que j'aime parcourir les boucles pour le nombre, puis utiliser des décalages pour l'indexation. Je trouve qu'il est plus facile de raisonner sur mon code de cette façon, et je trouve que les opérations sont plus faciles, mais vous pourriez potentiellement le changer si vous le souhaitez.

Public Sub CopyDataDynamically()
    Dim inputSheet As Worksheet
    Dim outputSheet As Worksheet

    Dim headers As Scripting.Dictionary
    Set headers = New Scripting.Dictionary

    Dim header As String
    Dim data As String

    Dim inputRow As Long
    Dim inputColumn As Long

    Set inputSheet = Worksheets("Sheet1")
    Set outputSheet = Worksheets("Sheet2")

    inputRow = 1

    While Not inputSheet.Cells(inputRow, 1) = ""
        inputCol = 1
        While Not inputSheet.Cells(inputRow, inputCol) = ""

            header = inputSheet.Cells(inputRow, inputCol).Value
            data = inputSheet.Cells(inputRow + 1, inputCol).Value

            If Not headers.Exists(header) Then
                headers.Add header, New Scripting.Dictionary
            End If
            headers(header).Add ((inputRow - 1) / 2) + 1, data
            inputCol = inputCol + 1
        Wend
        inputRow = inputRow + 2
    Wend

    'Output the structure to the new sheet
    For c = 0 To headers.Count - 1
        outputSheet.Cells(1, c + 1).Value = headers.Keys(c)
        For r = 0 To ((inputRow - 1) / 2) - 1
            If headers(headers.Keys(c)).Exists(r + 1) Then
                outputSheet.Cells(r + 2, c + 1).Value = headers(headers.Keys(c))(r + 1)
            End If
        Next
    Next
End Sub
1
Blackhawk 31 janv. 2017 à 19:34

Je suggère, plutôt que de copier colonne par colonne, de copier plutôt ligne par ligne.

Public Sub CopyData()
    Dim inputRow As Long
    Dim outputRow As Long
    Dim inputSheet As Worksheet
    Dim outputSheet As Worksheet

    Set inputSheet = Worksheets("Sheet1")
    Set outputSheet = Worksheets("Sheet2")

    'First, copy the headers
    inputSheet.Rows(1).Copy outputSheet.Rows(1)

    'Next, copy the first row of data
    inputSheet.Rows(2).Copy outputSheet.Rows(2)

    'Loop through the rest of the sheet, copying the data row for each additional header row
    inputRow = 3
    outputRow = 3
    While inputSheet.Cells(inputRow, 1) <> ""
        inputRow = inputRow + 1 'increment to the data row
        inputSheet.Rows(inputRow).Copy outputSheet.Rows(outputRow)
        inputRow = inputRow + 1 'increment to the next potential header row
        outputRow = outputRow + 1 'increment to the next blank output row
    Wend
End Sub
1
Blackhawk 31 janv. 2017 à 17:02