excel - 如何移动和转置来自不同数量的不同列的数据？

问题描述

我正在处理来自 SAP 程序的 18,000 个数据，我需要按内容行组织它们。A 列和 C 列中的零件编号必须匹配（C 列中的编号应与第一次出现在 A 列中的位置一致），并且 C 列中提供的描述应转置到该匹配行（复制 + 粘贴特殊转置，然后从列中删除）。

我对代码的想法是这样的（我不是程序员）：

在 B、C 和 D 列中选择感兴趣的区域；
在 A 列中，在 C 列中找到与所选间隔的部件号匹配的第一个单元格 - 保存此行；
缩短间隔；
将所选区域（步骤 1）粘贴到步骤 2 中保存的行的 B 列中；
复制 D 列中的描述并在已保存行的 E 列中粘贴特殊（转置）；
在D列中，从已保存的行+1中选择内容，直到该列的单元格中没有更多数据并删除；
结尾。

https://drive.google.com/file/d/1zf1maftGdCfupdAA7R0TNc6lzPnQrJ0j/view?usp=sharing（这是我正在处理的实际工作表的一小部分）。

目前宏代码如下：

Sub Macro2()
'
' Macro2 Macro
'

'
    Range("B20:D22").Select
    Selection.Cut
    Range("B8").Select
    ActiveSheet.Paste
    Range("D8:D10").Select
    Selection.Copy
    Range("E8").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("D9:D10").Select
    Application.CutCopyMode = False
    Selection.ClearContents
End Sub

第 1 行和第 5 行是最终外观的示例（我必须对 C 和 A 列中的下一个部件号做同样的事情）。宏应该移动数据，直到零件编号第一次出现在 A 列中，执行匹配并从列到行转置描述。

标签： excelvba

解决方案

我建议如下：

Option Explicit

Public Sub ReOrganizeData()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("DataSheet")  'define your worksheet

    Dim LastRow As Long  'find last used row in column D
    LastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

    'find first row with data in column B
    Dim StartRow As Long
    If ws.Cells(1, "B").Value = vbNullString Then
        StartRow = ws.Cells(1, "B").End(xlDown).Row
    Else
        StartRow = 1
    End If

    Dim MatchedRow As Double
    Dim EndRow As Long

    Do While StartRow < LastRow  'loop through all data
        'find end row
        EndRow = ws.Cells(StartRow, "B").End(xlDown).Row - 1
        If EndRow > LastRow Then EndRow = LastRow  'check for last row overflow

        'match data in column C with data in column A
        MatchedRow = Application.Match(ws.Cells(StartRow, "C").Value, ws.Columns("A"), 0)
        If Not IsError(MatchedRow) Then
            'check if matched row is free
            If ws.Cells(MatchedRow, "D").Value <> vbNullString Then
                MsgBox "The row " & MatchedRow & " where I need to write data is not empty. Something went wrong.", vbCritical
                Exit Sub
            End If

            'move data B and C
            ws.Cells(MatchedRow, "B").Resize(1, 2).Value = ws.Cells(StartRow, "B").Resize(1, 2).Value
            ws.Cells(StartRow, "B").Resize(1, 2).Clear

            'transpose data D
            ws.Cells(MatchedRow, "D").Resize(1, EndRow - StartRow + 1).Value = Application.Transpose(ws.Cells(StartRow, "D").Resize(EndRow - StartRow + 1, 1).Value)
            ws.Cells(StartRow, "D").Resize(EndRow - StartRow + 1, 1).Clear
        Else
            MsgBox "Data '" & ws.Cells(StartRow, "C").Value & "' could not be matched with column A.", vbExclamation
        End If

        'set new start row
        StartRow = EndRow + 1
    Loop
End Sub

使用这些数据……</p>

^{图 1：“DataSheet”的输入数据。}

…它会输出这个：

^{图 2：转换后“DataSheet”中的数据。}

excel - 如何移动和转置来自不同数量的不同列的数据？

问题描述

解决方案

推荐阅读