使用VBA按条件转置指定列并生成新数据表

我在Excel中有一个含100余列的表格，大量列名以INFO_COMPLETE_为前缀，这些列仅包含西班牙语的VERDADERO（真）和FALSO（假）两个值。需要将这类列转置生成新表，仅保留原表的ID_ELEMENT和NAME列，目标表需包含ID_ELEMENT、NAME、FIELD、VALUE四列。现有VBA代码仅保留FALSO值且缺少VALUE列，需修改代码并简化。

原表结构 #

目标表结构 #

现有VBA代码 #

Sub PivotColumnsToRows()
    
    ' Variables
    Dim tblDatos As ListObject
    Dim tblNew As ListObject
    Dim newTablename As String
    Dim i As Long, j As Long, k As Long
    Dim ID_ELEMENT As String, nameElement As String, columnElement As String
    Dim bValor As Boolean
    Dim NewSheet As String
    NewSheet = "TABLA_PIVOT" ' Name of the new Sheet
    ThisWorkbook.Worksheets.Add().Name = NewSheet ' Create new Sheet
    
    ' Name of the new table
    newTablename = "DATOS_PIVOT"
    
    ' Reference of the original table (name "Tabla4"), Sheetsname "DATOS"
    Set tblDatos = ThisWorkbook.Worksheets("DATOS").ListObjects("Tabla4")
    
    ' Create new table
    Set tblNew = ThisWorkbook.Worksheets(NewSheet).ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes)
    tblNew.Name = newTablename
    
    ' Add columns to the new table
    With tblNew
        .ListColumns.Add
        .ListColumns.Add
        .ListColumns.Add
    End With
    
    ' Rename columns of the new table
    With tblNew
        .HeaderRowRange(1) = "ID_ELEMENT"
        .HeaderRowRange(2) = "NAME"
        .HeaderRowRange(3) = "FIELD"
    End With
    
    ' Loop for columns of the original table
    For i = 1 To tblDatos.ListColumns.Count
        
        ' "INFO_COMPLETE_"
        If InStr(tblDatos.ListColumns(i).Name, "INFO_COMPLETE_") = 1 Then
            
            ' loop for rows
            For j = 1 To tblDatos.ListRows.Count
                
                ' get ID and name
                ID_ELEMENT = tblDatos.DataBodyRange(j, 1)
                nameElement = tblDatos.DataBodyRange(j, 2)
                
                ' Check the value in the current column
                bValor = tblDatos.DataBodyRange(j, i)
                
                ' If the value is FALSE, add a row to the new table
                If Not bValor Then
                    
                    ' get the name of the actual column
                    columnElement = tblDatos.ListColumns(i).Name
                    
                    ' Add row to the new table
                    tblNew.ListRows.Add
                    k = tblNew.ListRows.Count
                    
                    ' Write values in the new file
                    With tblNew
                        .DataBodyRange(k, 1) = ID_ELEMENT
                        .DataBodyRange(k, 2) = nameElement
                        .DataBodyRange(k, 3) = columnElement
                    End With
                    
                End If
                
            Next j
            
        End If
        
    Next i
    
    ' Style
    tblNew.TableStyle = "TableStyleMedium2"
    
End Sub

修改并简化后的VBA代码 #

Sub TransposeInfoColumns()
    ' 变量声明
    Dim tblSource As ListObject
    Dim wsTarget As Worksheet
    Dim tblTarget As ListObject
    Dim col As ListColumn
    Dim row As ListRow
    Dim targetRow As ListRow
    Dim idVal As String, nameVal As String, fieldName As String, fieldVal As String
    
    ' 定义常量
    Const TARGET_SHEET_NAME As String = "TABLA_PIVOT"
    Const TARGET_TABLE_NAME As String = "DATOS_PIVOT"
    
    ' 引用源表（需确保表名和工作表名正确）
    Set tblSource = ThisWorkbook.Worksheets("DATOS").ListObjects("Tabla4")
    
    ' 创建或激活目标工作表
    On Error Resume Next
    Set wsTarget = ThisWorkbook.Worksheets(TARGET_SHEET_NAME)
    On Error GoTo 0
    If wsTarget Is Nothing Then
        Set wsTarget = ThisWorkbook.Worksheets.Add
        wsTarget.Name = TARGET_SHEET_NAME
    Else
        ' 清空原有数据（不需要保留历史可注释此行）
        wsTarget.Cells.Clear
    End If
    
    ' 创建目标表并设置表头
    wsTarget.Range("A1:D1") = Array("ID_ELEMENT", "NAME", "FIELD", "VALUE")
    Set tblTarget = wsTarget.ListObjects.Add(xlSrcRange, wsTarget.Range("A1:D1"), , xlYes)
    tblTarget.Name = TARGET_TABLE_NAME
    
    ' 遍历源表中所有以INFO_COMPLETE_开头的列
    For Each col In tblSource.ListColumns
        If Left(col.Name, 15) = "INFO_COMPLETE_" Then ' 直接匹配前缀长度，效率更高
            fieldName = col.Name
            ' 遍历源表每一行
            For Each row In tblSource.ListRows
                idVal = row.Range(1).Value
                nameVal = row.Range(2).Value
                fieldVal = row.Range(col.Index).Value
                
                ' 添加新行到目标表并赋值
                Set targetRow = tblTarget.ListRows.Add
                targetRow.Range(1).Value = idVal
                targetRow.Range(2).Value = nameVal
                targetRow.Range(3).Value = fieldName
                targetRow.Range(4).Value = fieldVal
            Next row
        End If
    Next col
    
    ' 设置表样式
    tblTarget.TableStyle = "TableStyleMedium2"
End Sub

修改说明 #

1. 新增VALUE列：目标表直接创建4列，包含VALUE字段，每次循环都将源列的实际值写入目标表。
2. 保留所有值：删除了原代码中仅保留FALSO的判断条件，所有VERDADERO和FALSO值都会被转置。
3. 优化工作表创建逻辑：先检查目标工作表是否存在，避免重复创建报错；若存在可选择清空原有数据。
4. 提升前缀匹配效率：用Left(col.Name, 15)替代InStr，直接匹配前缀固定长度，减少字符串查找开销。
5. 简化循环逻辑：使用For Each遍历列和行，代码更简洁易读；减少不必要的变量声明。
6. 避免动态列错误：原代码创建新表时依赖空单元格的CurrentRegion，可能导致列数异常，现在直接指定表头范围创建表，稳定性更强。

内容的提问来源于stack exchange，提问作者danny