Excel自动分列VBA程序

Option Explicit

Private Sub cmdStart_Click()

'''获取最大行数、列数和数据区域 Dim MAXROW As Integer Dim MAXCOLUMN As Integer

MAXROW = 2 MAXCOLUMN = 2

MAXROW = ActiveWorkbook.ActiveSheet.UsedRange.Rows.Count

MAXCOLUMN = ActiveWorkbook.ActiveSheet.UsedRange.Columns.Count

Dim FirstRow As Integer Dim BlankColumn As Integer

Dim CutCount As Integer

Dim OptionNumber As Integer Dim i As Integer

If chkFirstRow.Value = True Then FirstRow = 1 Else

FirstRow = 0 End If

If chkBlankColumn.Value = True Then BlankColumn = 1 Else

BlankColumn = 0

End If

OptionNumber = Val(cmbOptionNumber.Value)

'''按列分

If optColumnNumber.Value = True Then Dim RowCount As Integer RowCount = 1

If MAXROW - FirstRow > OptionNumber Then

If (MAXROW - FirstRow) Mod OptionNumber = 0 Then RowCount = (MAXROW - FirstRow) \\ OptionNumber Else

RowCount = (MAXROW - FirstRow) \\ OptionNumber + 1 End If

For i = 1 To OptionNumber - 1

Range(Cells(FirstRow + RowCount * i + 1, 1), Cells(FirstRow + RowCount * (i + 1), MAXCOLUMN)).Select

Selection.Copy

Cells(FirstRow + 1, (MAXCOLUMN + BlankColumn) * i + 1).Select Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Application.CutCopyMode = True

If chkFirstRow.Value = True Then

Range(Cells(1, 1), Cells(1, MAXCOLUMN)).Select Selection.Copy

Cells(1, (MAXCOLUMN + BlankColumn) * i + 1).Select Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False End If Next

Range(Cells(FirstRow + RowCount + 1, 1), Cells(MAXROW, MAXCOLUMN)).Select Selection.Clear End If End If

'''按行分

If optRowNumber.Value = True Then

Dim ColNum As Integer ColNum = 1

If MAXROW - FirstRow > OptionNumber Then

If (MAXROW - FirstRow) Mod OptionNumber = 0 Then ColNum = (MAXROW - FirstRow) \\ OptionNumber Else

ColNum = (MAXROW - FirstRow) \\ OptionNumber + 1 End If

For i = 1 To ColNum - 1

Range(Cells(FirstRow + OptionNumber * i + 1, 1), Cells(FirstRow + OptionNumber * (i + 1), MAXCOLUMN)).Select Selection.Copy

Cells(FirstRow + 1, (MAXCOLUMN + BlankColumn) * i + 1).Select Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Application.CutCopyMode = True

If chkFirstRow.Value = True Then

Range(Cells(1, 1), Cells(1, MAXCOLUMN)).Select Selection.Copy

Cells(1, (MAXCOLUMN + BlankColumn) * i + 1).Select Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False End If Next

Range(Cells(FirstRow + OptionNumber + 1, 1), Cells(MAXROW, MAXCOLUMN)).Select

Selection.Clear End If End If

MAXROW = ActiveWorkbook.ActiveSheet.UsedRange.Rows.Count

MAXCOLUMN = ActiveWorkbook.ActiveSheet.UsedRange.Columns.Count If chkBlankColumn.Value = True Then MAXCOLUMN = MAXCOLUMN + 1 End If

Range(Cells(1, 1), Cells(MAXROW, MAXCOLUMN)).Select

Dim SetBorder As Boolean

SetBorder = SetBorderLines(True) End Sub

Private Sub UserForm_Activate() Dim i As Integer For i = 1 To 100

cmbOptionNumber.AddItem i Next End Sub