excel 乾坤大挪移

你不需要将工作表手动分类；

只需要在”已整理“的标题行增加标题列，

listbox会自动获取”已整理“sheet中的标题列，并列出来

你只需要选中同一列中的单元格，点击想移动到的列表的类别，双击或者点击移动，软件就自动将选中的单元格移动到”已整理“表的指定列的同一行中，对于有几十个列的表格，这样自动移动比手动粘贴要快得多。 

整理前： 

整理后 

'=================================================================================
Private Sub cmd_REF_listbox_Click()
'刷新列表框
UpdateColumnList
End Sub

Private Sub CommandButton1_Click()
Selection.Cut
End Sub

Private Sub CommandButton2_Click()
ActiveSheet.Paste
End Sub

Sub MoveSelectedCellsToSortedSheet()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim targetCol As Long
    Dim minRow As Long
    Dim minCol As Long
    Dim lastROW As Long
    Dim rngSelected As Range
    Dim cell As Range
    Dim headerRow As Range
    Dim i_not_empty As Integer
    Dim Col_Name As String, Flg_HeBing As Integer
    Dim tem_S$, tem_S1$
    
    
    Col_Name = T_ColName.Text
    Flg_HeBing = 0
    If InStr(Col_Name, "备注") > 0 Then
        Flg_HeBing = 1
    End If
    
    ' 获取当前工作表
    Set wsSource = ActiveSheet
    
    ' 检查是否存在“整理后”工作表
    On Error Resume Next
    Set wsTarget = Worksheets("整理后")
    On Error GoTo 0
    
    If wsTarget Is Nothing Then
        ' 如果不存在，则创建
        Set wsTarget = Sheets.Add(After:=Sheets(Sheets.Count))
        wsTarget.Name = "整理后"
    End If
    
    ' 获取选定的单元格
    Set rngSelected = Selection
    minRow = rngSelected.Cells(1).Row
    minCol = rngSelected.Cells(1).Column

    
    ' 在“整理后”工作表的第一行中查找用户选择的标题
    Set headerRow = wsTarget.Rows(1)
    On Error Resume Next
    targetCol = Application.WorksheetFunction.Match(Col_Name, headerRow, 0)
    
    ' 如果找不到标题则退出子程序
    If IsError(targetCol) Then
        MsgBox "未找到目标列标题 " & Col_Name & vbExclamation
        Exit Sub
    End If
    
    ' 确定目标行
    lastROW = minRow
    
    ' 遍历选定的单元格
    i_not_empty = 0
    tem_S = ""
    For Each cell In rngSelected
        ' 移动单元格数据,覆盖相同值，填写空的单元格
        tem_S1 = wsTarget.Cells(lastROW, targetCol).Value
        If Flg_HeBing = 1 Then
        '数据融合在同一个单元格中
                wsTarget.Cells(lastROW, targetCol).Value = tem_S1 & ";" & cell.Value
                lastROW = lastROW + 1
                cell.Value = ""
        Else
            If IsCellEmpty(wsTarget.Cells(lastROW, targetCol)) Or tem_S1 = cell.Value Then
                wsTarget.Cells(lastROW, targetCol).Value = cell.Value
                lastROW = lastROW + 1
                cell.Value = ""
            Else
            '不相同的数据要保留
                i_not_empty = i_not_empty + 1
                lastROW = lastROW + 1
                ' 处理目标单元格已存在的逻辑
                tem_S = tem_S & vbCrLf & "目标单元格 " & wsTarget.Cells(lastROW, targetCol).Address & " 已经有数据。"
                
            End If
        End If
    Next cell
    If i_not_empty = 0 Then
    ' 清理被移动的单元格
        rngSelected.ClearContents
    Else
        MsgBox tem_S
    End If
    tem_S = ""
End Sub

' 更新ListBox中的列标题
Sub UpdateColumnList()
    Dim wsTarget As Worksheet
    Dim headerRow As Range
    Dim i As Integer
    Dim lastROW As Integer
    ' 获取“整理后”工作表
    Set wsTarget = Worksheets("整理后")
    
    ' 获取第一行的数据作为列标题
    Set headerRow = wsTarget.Rows(1)
    
    ' 清空ListBox
    Frm_ShuXingZhengLi.lstColumns.Clear
    
    ' 将列标题添加到ListBox中
    lastROW = headerRow.Find("*", LookIn:=xlValues, lookat:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    For i = 1 To lastROW
        Frm_ShuXingZhengLi.lstColumns.AddItem headerRow.Cells(i).Value
    Next i
End Sub

' 判断单元格是否为空
Function IsCellEmpty(targetCell As Range) As Boolean
    If IsError(targetCell.Value) Or IsEmpty(targetCell.Value) Then
        IsCellEmpty = True
    Else
        IsCellEmpty = False
    End If
End Function

Private Sub CommandButton3_Click()
If lstColumns.ListIndex > 10 Then
lstColumns.ListIndex = lstColumns.ListIndex - 10
Else
lstColumns.ListIndex = 0
End If
End Sub

Private Sub CommandButton4_Click()
If lstColumns.ListIndex + 10 < lstColumns.ListCount Then
lstColumns.ListIndex = lstColumns.ListIndex + 10
Else
lstColumns.ListIndex = lstColumns.ListCount - 1
End If
End Sub

Private Sub lstColumns_Click()

T_ColName.Text = lstColumns.Text
End Sub

Private Sub lstColumns_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'移动单元格到listbox指定的列
MoveSelectedCellsToSortedSheet
End Sub

Private Sub Move_cell_Click()
'移动单元格到listbox指定的列
MoveSelectedCellsToSortedSheet
End Sub
Sub Ref1()
 UpdateColumnList '刷新列表框
End Sub

Private Sub UserForm_Click()

End Sub

Private Sub UserForm_Initialize()
Ref1
End Sub