乾坤大挪移--将一个混乱的excel分类整理的辅助VBA代码

excel 乾坤大挪移

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

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

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

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

整理前： 

整理后 

'=================================================================================
Private Sub cmd_REF_listbox_Click()
'刷新列表框
UpdateColumnList
End SubPrivate Sub CommandButton1_Click()
Selection.Cut
End SubPrivate Sub CommandButton2_Click()
ActiveSheet.Paste
End SubSub MoveSelectedCellsToSortedSheet()Dim wsSource As WorksheetDim wsTarget As WorksheetDim targetCol As LongDim minRow As LongDim minCol As LongDim lastROW As LongDim rngSelected As RangeDim cell As RangeDim headerRow As RangeDim i_not_empty As IntegerDim Col_Name As String, Flg_HeBing As IntegerDim tem_S$, tem_S1$Col_Name = T_ColName.TextFlg_HeBing = 0If InStr(Col_Name, "备注") > 0 ThenFlg_HeBing = 1End If' 获取当前工作表Set wsSource = ActiveSheet' 检查是否存在“整理后”工作表On Error Resume NextSet wsTarget = Worksheets("整理后")On Error GoTo 0If wsTarget Is Nothing Then' 如果不存在，则创建Set wsTarget = Sheets.Add(After:=Sheets(Sheets.Count))wsTarget.Name = "整理后"End If' 获取选定的单元格Set rngSelected = SelectionminRow = rngSelected.Cells(1).RowminCol = rngSelected.Cells(1).Column' 在“整理后”工作表的第一行中查找用户选择的标题Set headerRow = wsTarget.Rows(1)On Error Resume NexttargetCol = Application.WorksheetFunction.Match(Col_Name, headerRow, 0)' 如果找不到标题则退出子程序If IsError(targetCol) ThenMsgBox "未找到目标列标题 " & Col_Name & vbExclamationExit SubEnd If' 确定目标行lastROW = minRow' 遍历选定的单元格i_not_empty = 0tem_S = ""For Each cell In rngSelected' 移动单元格数据,覆盖相同值，填写空的单元格tem_S1 = wsTarget.Cells(lastROW, targetCol).ValueIf Flg_HeBing = 1 Then'数据融合在同一个单元格中wsTarget.Cells(lastROW, targetCol).Value = tem_S1 & ";" & cell.ValuelastROW = lastROW + 1cell.Value = ""ElseIf IsCellEmpty(wsTarget.Cells(lastROW, targetCol)) Or tem_S1 = cell.Value ThenwsTarget.Cells(lastROW, targetCol).Value = cell.ValuelastROW = lastROW + 1cell.Value = ""Else'不相同的数据要保留i_not_empty = i_not_empty + 1lastROW = lastROW + 1' 处理目标单元格已存在的逻辑tem_S = tem_S & vbCrLf & "目标单元格 " & wsTarget.Cells(lastROW, targetCol).Address & " 已经有数据。"End IfEnd IfNext cellIf i_not_empty = 0 Then' 清理被移动的单元格rngSelected.ClearContentsElseMsgBox tem_SEnd Iftem_S = ""
End Sub' 更新ListBox中的列标题
Sub UpdateColumnList()Dim wsTarget As WorksheetDim headerRow As RangeDim i As IntegerDim lastROW As Integer' 获取“整理后”工作表Set wsTarget = Worksheets("整理后")' 获取第一行的数据作为列标题Set headerRow = wsTarget.Rows(1)' 清空ListBoxFrm_ShuXingZhengLi.lstColumns.Clear' 将列标题添加到ListBox中lastROW = headerRow.Find("*", LookIn:=xlValues, lookat:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).ColumnFor i = 1 To lastROWFrm_ShuXingZhengLi.lstColumns.AddItem headerRow.Cells(i).ValueNext i
End Sub' 判断单元格是否为空
Function IsCellEmpty(targetCell As Range) As BooleanIf IsError(targetCell.Value) Or IsEmpty(targetCell.Value) ThenIsCellEmpty = TrueElseIsCellEmpty = FalseEnd If
End FunctionPrivate Sub CommandButton3_Click()
If lstColumns.ListIndex > 10 Then
lstColumns.ListIndex = lstColumns.ListIndex - 10
Else
lstColumns.ListIndex = 0
End If
End SubPrivate Sub CommandButton4_Click()
If lstColumns.ListIndex + 10 < lstColumns.ListCount Then
lstColumns.ListIndex = lstColumns.ListIndex + 10
Else
lstColumns.ListIndex = lstColumns.ListCount - 1
End If
End SubPrivate Sub lstColumns_Click()T_ColName.Text = lstColumns.Text
End SubPrivate Sub lstColumns_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'移动单元格到listbox指定的列
MoveSelectedCellsToSortedSheet
End SubPrivate Sub Move_cell_Click()
'移动单元格到listbox指定的列
MoveSelectedCellsToSortedSheet
End Sub
Sub Ref1()UpdateColumnList '刷新列表框
End SubPrivate Sub UserForm_Click()End SubPrivate Sub UserForm_Initialize()
Ref1
End Sub