VBA / Excel-将基于“矩阵”的数据集迁移到数据库

Question

I am trying to migrate a dataset from an old spreadsheet based system to a database. And I have one outstanding single issue to solve.

I have a sheet within a spreadsheet that is acting like a many-to-many table:

• It has a column names
• It also has a leading column as a rowID/Name making rows unique

• On the crossing of rows and columns I have either an empty cell or an 'X' (X worked in old system as a relation between two different data sets)

  Rows_name|Column_name1 |Column_name2 |Column_nameX

  Row_name1| | X | X

  Row_name2| X | |

  Row_name3| X | X | X

For each found 'X' I require to copy Row_name and Column_name to separate sheet ready for export.

IE For Row_name3 it would be three new rows in a new sheet as Row_name3 has three 'X's

Rows_name|Column_name

Row_name3|Column_name1

Row_name3|Column_name2

Row_name3|Column_name3

In effect I am solving a many to many relation by having a third table.

Therefore I am looking for a help with the algorithm to find all related column/row names for each 'X'.

For any suggestions how to tackle this I would be very grateful.

Answer 1

Is this what you are trying?

Option Explicit

Sub Sample()
    Dim wsInput As Worksheet, wsOutput As Worksheet
    Dim LRI As Long, LRO As Long, i As Long, j As Long

    '~~> Input Sheet
    Set wsInput = Sheets("Sheet1")
    LRI = wsInput.Range("A" & wsInput.Rows.Count).End(xlUp).Row

    '~~> Output Sheet
    Set wsOutput = Sheets("Sheet2")
    LRO = 2

    For i = 2 To LRI
        With wsInput
            For j = 1 To 3
                If UCase(Trim(.Range("A" & i).Offset(, j).Value)) = "X" Then
                    .Range("A" & i).Copy wsOutput.Range("A" & LRO)
                    .Range("A1").Offset(, j).Copy wsOutput.Range("B" & LRO)
                    LRO = LRO + 1
                End If
            Next
        End With
    Next i
End Sub

SNAPSHOT