1

sheet1 sheet2

The problem i run into is that sometimes entire headers and data values are missing in the dataset and therefore using the last row in the script the data is shifted up by one. For example, if i removed H11:H12 completely on sheet1 then the values for the H column associated with the data set in A11:K11 will actually be from the data set A13:K13 (or cell value H14).

The spaces shown in the second image would not be present if the respective header is not present.

Question: Given the following code; Do you think it is possible to match the data to headers and use the original offset row number alongside the column that it is matched to on sheet 2 and paste the values there? Instead the current code (and only method that worked was to find the last row).

Examples/Thoughts: I'm thinking that the script will have to take a cell (such as D9 and recognizes it is a D and offsets to select D10 and matches that D9 record to sheet 2 column D and pastes the D10 data in D10 rather than D5.

second example, Script takes I17 and recognizes it matches I to sheet 2 column I and then offsets to select/copy and pastes the I19 data in I18 rather than 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

Addition: enter image description here

Seems like there is an exception that prevents these cell values from being copied over, if i do it manually the below screenshot would be correct. Any tips to diagnose?

enter image description here

Very strange because the line with the red dot copies fine in both but those four lines seem to fail.

Improve this question
14
  • The data in the photos is not the actual data but rather it is just placeholders. A to K represent the category headers. Any value of number of special character denotes the data that is being collected under each category. As you may notice some categories do not have a value for the particular data set (row number) and hence I can't find a way for it to copy over the blank cells to the second sheet. Instead under the current code it simply ignores any blanks. That is why i wanted to perhaps offset where it pastes the data in the second sheet the data set's original row number. Commented Jan 17, 2017 at 18:11
  • So you're trying to convert the top data into the bottom data - basically just strip out the extra headers? Two questions: is it guaranteed that all the headers in the first row will be filled in, and is it guaranteed that every other row will be a header row? Commented Jan 31, 2017 at 15:55
  • Also, are you making the changes to this same sheet or are you trying to copy to a new sheet? Commented Jan 31, 2017 at 15:59
  • It is copying the data to a new sheet with the predefined headers in the range A1:K1. I think i may need to rebuild completely knowing now that using the last row has so many issues, what I think might work is if you know a way to pull the row value from the original data when the macro is running and then we assign that as a variable and use it to paste the data in sheet2 with the correct column that was found during the data matching. Commented Jan 31, 2017 at 16:13
  • For example, the macro detects the data set ranging from A2:K3 and recognizes row 2 as the headers and row 3 as the values. It proceeds to assign a variable with the value 3, designating the row number the values originated from. It proceeds to match the data to correct headers A to A, B to B, and so on but when it pastes the values, instead of using the last row (like it currently does) it will refer the the variable for the row input (in this case its row 3). Then all i would need to do is delete all completely blank rows, just simple formatting. Commented Jan 31, 2017 at 16:20

2 Answers 2

Reset to default
1

I'm leaving my previous answer up for posterity's sake, but now that you've clarified your question I have a better answer for you.

I'm going to assume the following: 1. every two rows is a pair of headers/data; 2. the sets of row pairs may be unequal in length because if a particular header is missing for a particular row pair, there is no blank because the headers/data are shifted left; 3. there will be no blanks in the header rows until the end of the row 4. there may be blanks in the data row 5. the output should be every header (even if it only appears in 1 row) and rows of the associated data, one per header/data pair in the original sheet.

For example:

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

is a valid input sheet and the resulting output sheet would be:

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

Use a Scripting.Dictionary of Scripting.Dictionarys to keep track of the possibly different length row pairs of headers/data. The Scripting.Dictionary of headers allows you to add new headers as they appear. The nested Scripting.Dictionarys allow you to keep track of only those rows which have a value for a particular header, but also preserve the row number for later.

As noted in the comments, the code iterates through this structure to display ALL headers and the data associated with each row. "((inputRow - 1) / 2)" calculates the output row number. You'll notice I like to iterate for loops over the count and then use offsets for indexing. I find it easier to reason about my code this way, and I find operations are easier, but you could potentially change it if you want.

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
Improve this answer
Sign up to request clarification or add additional context in comments.

8 Comments

Should i define the dictionary to avoid the user defined type not defined? Dim headers Set headers = CreateObject("Scripting.Dictionary")
You can use "early binding" to have VBA recognize this code directly by clicking (in the VBA IDE) "Tools"--->"References..." and checking the box next to "Microsoft Scripting Runtime". I prefer this over "late binding" (using CreateObject) because you get access to intelliense and the object model via F2.
Very true, You're truly an excel wizard.
The one unfortunate thing that seems to be happening is that when it generates the headers it comes back and creates multiple duplicates after adding a missing heading. Would it be easier if i preset the headers somewhere?
Can you be more specific? The code works correctly if my assumptions are true - there is likely something about your data that doesn't match the assumptions
|
1

I suggest, rather than copying column by column, you instead copy row by row.

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
Improve this answer

16 Comments

I will try out this code in about an hour and will let you know if it works out!
Thank you for your time in helping me with this problem as well, i know we all live busy lives.
The only problem that comes up is the following: I'll have rows with headers of A B C D E F G H I J K and others with A B C D E G H I J K. Hence they will fail to line up with respective headers without individual data matching.
Is the first header row guaranteed to have ALL the headers?
Do you mean like H9 and H10 being blank like in the example? My code will still work.
|

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.