时间戳

首页 > 解决方案 > 将多列填充到行中，同时在某些列中保留信息 (Excel)

excel - 将多列填充到行中，同时在某些列中保留信息 (Excel)

问题描述

我一直在尝试寻找能够将我当前的表格（从 A1）转换为预期格式（A7）的 VBA 代码，如下表所示。

[当前与预期] [1]：https ://i.stack.imgur.com/GUQEU.png

我试过这样做，但它也没有填充到下面的行的第 1 到 3 列。

Sub ConvertTable()
'Update 20150512
Dim Rng As Range
Dim cRng As Range
Dim rRng As Range
Dim xOutRng As Range
xTitleId = "KutoolsforExcel"
Set cRng = Application.InputBox("Select your Column labels", xTitleId, Type:=8)
Set rRng = Application.InputBox("Select Your Row Labels", xTitleId, Type:=8)
Set Rng = Application.InputBox("Select your data", xTitleId, Type:=8)
Set outRng = Application.InputBox("Out put to (single cell):", xTitleId, Type:=8)
Set xWs = Rng.Worksheet
k = 1
xColumns = rRng.Column
xRow = cRng.Row
For i = Rng.Rows(1).Row To Rng.Rows(1).Row + Rng.Rows.Count - 1
    For j = Rng.Columns(1).Column To Rng.Columns(1).Column +     Rng.Columns.Count - 1
    outRng.Cells(k, 1) = xWs.Cells(i, xColumns)
    outRng.Cells(k, 2) = xWs.Cells(xRow, j)
    outRng.Cells(k, 3) = xWs.Cells(i, j)
    k = k + 1
Next j
Next i
End Sub

请感谢任何帮助！

标签： excelvba

解决方案

尝试

Option Explicit
Sub ConvertTable()
    'Update 20150512
    Dim xWs As Worksheet
    Dim cRng As Range, rRng As Range, rng As Range, outRng As Range
    Dim i As Long, j As Long, k As Long, n As Long, r As Long
    Dim xTitleId As String, YN As Variant

    xTitleId = "KutoolsforExcel"
    
    ' input
    Set cRng = Application.InputBox("Select your Column labels", xTitleId, Type:=8)
    Set rRng = Application.InputBox("Select Your Row Labels", xTitleId, Type:=8)
    Set rng = Application.InputBox("Select your data", xTitleId, Type:=8)
    Set outRng = Application.InputBox("Out put to (single cell):", xTitleId, Type:=8)
    Set xWs = rng.Worksheet

    ' output
    n = cRng.Columns.Count ' no of columns
    outRng.Offset(0, 1).Resize(1, n).Value2 = cRng.Value2
    outRng.Offset(0, n + 1) = "Answer" ' add on end
    r = 1
    For i = 1 To rRng.Columns.Count
    
        For j = 1 To rng.Rows.Count
            YN = rng.Cells(j, n + i).Value2 ' Yes/No
            
            If IsError(YN) Then
                ' skip if error
            ElseIf YN <> "" And YN <> 0 Then
                ' skip if 0 or blank
                outRng.Offset(r, 0) = rRng.Cells(1, i)
                For k = 1 To n
                    If Not IsError(rng.Cells(j, k)) Then
                        outRng.Offset(r, k).Value2 = rng.Cells(j, k).Value2
                    End If
                Next
                outRng.Offset(r, n + 1).Value2 = YN
                r = r + 1
            End If
        Next
    Next
End Sub

更新 - 排除答案列中带有 #N/A 的行

update2 - 排除空格和 0

推荐阅读