EXCEL行移动和列移动vba_EXCEL梦想之家

这是个玩彩票的朋友要求做的。

我可以帮您试一下，请HI我.
回答者： lxlzmh2002 - 魔导师十级 2009-8-31 23:31
=================================================================
再来更新此贴:

一. 移动程序代码:
Sub ToMove()

'this program is designed for cells moving by lxlzmh2002 on Sep 2,2009

Dim sht As Object
Dim rs As Long
Dim cs As Long
Dim i As Long
Dim rc As String
Dim mf As String
Dim mt As String
Dim rcs As Long
Dim os As Integer

Application.EnableEvents = False
Application.ScreenUpdating = False

'moving commands checking
os = 1
Sheets("order").Select
rs = Range("A65536").End(xlUp).Row
For i = 2 To rs
    If InStr(1, Cells(i, 1), "：") <> 0 Then
       Cells(i, 1) = WorksheetFunction.Substitute(Cells(i, 1), "：", ":")
    End If

    If (Left(Cells(i, 1), 1) = "r" Or Left(Cells(i, 1), 1) = "c") And InStr(1, Cells(i, 1), ":") <> 0 Then
    Else
        MsgBox "注意: 第 " & i - 1 & " 行指令存在错误，请修正后再重试本程序!"
        GoTo er
    End If
    If Not WorksheetFunction.IsNumber(CInt(Trim(Mid(Cells(i, 1), InStr(1, Cells(i, 1), ":") + 1, Len(Cells(i, 1)))))) Then
        MsgBox "注意: 第 " & i - 1 & " 行指令中的移动到位置存在错误，请修正后再重试本程序!"
        GoTo er
    End If

    Cells(i, 1) = LCase(Left(Cells(i, 1), 1)) & Mid(Cells(i, 1), 2, Len(Cells(i, 1)))
Next i

'create result sheet
On Error Resume Next
Set sht = Sheets("result")
If Err.Number = 0 Then
   Sheets("result").Select
   Sheets("result").Range("1:65536").ClearContents
   Sheets("main").Range("1:" & Sheets("main").Range("A65536").End(xlUp).Row).Copy Sheets("result").Range("A1")
Else
   Sheets("main").Copy after:=Sheets(Sheets.Count)
   ActiveSheet.Name = "result"
   ActiveWorkbook.Sheets("result").Tab.ColorIndex = 44
End If

' to move

Sheets("result").Select
For i = 2 To rs
    rc = Left(Sheets("order").Cells(i, 1), 1)
    mf = Replace(Mid(Sheets("order").Cells(i, 1), 2, InStr(1, Sheets("order").Cells(i, 1), ":") - 2), "-", ":")
    If InStr(1, mf, ":") = 0 Then
       mf = CStr(CLng(mf) + os)
    Else
       mf = CStr(Left(mf, InStr(1, mf, ":") - 1) + os) & ":" & CStr(Mid(mf, InStr(1, mf, ":") + 1, Len(mf)) + os)
    End If

    mt = CStr(CLng(Trim(Mid(Sheets("order").Cells(i, 1), InStr(1, Sheets("order").Cells(i, 1), ":") + 1, Len(Sheets("order").Cells(i, 1))))) + os)

    Select Case rc
    Case "r"
        rcs = Rows(mf).Count
        If Rows(mf).Row <= Rows(mt).Row Then
           Range(CStr(CLng(mt) + rcs) & ":" & CStr(CLng(mt) + 2 * rcs - 1)).EntireRow.Insert
           Rows(mf).EntireRow.Copy Cells(CLng(mt) + rcs, 1)
           Rows(mf).EntireRow.Delete
        Else
           Range(mt & ":" & CStr(CLng(mt) + rcs - 1)).EntireRow.Insert
           Range(CStr(Rows(mf).Row + rcs) & ":" & CStr(Rows(mf).Row + 2 * rcs - 1)).EntireRow.Copy Cells(mt, 1)
           Range(CStr(Rows(mf).Row + rcs) & ":" & CStr(Rows(mf).Row + 2 * rcs - 1)).EntireRow.Delete
        End If
    Case "c"
        If InStr(1, mf, ":") = 0 Then
           mf = cn(CLng(mf))
        Else
           mf = cn(CLng(Left(mf, InStr(1, mf, ":") - 1))) & ":" & cn(CLng(Mid(mf, InStr(1, mf, ":") + 1, Len(mf))))
        End If
        mt1 = cn(CLng(mt))
        rcs = Columns(mf).Count
        Columns(mf).EntireColumn.Copy Sheets("order").Cells(1, Columns(mf).Column)
        Columns(mf).EntireColumn.Delete
        Columns(mt1 & ":" & cn(CLng(mt) + rcs - 1)).EntireColumn.Insert
        Sheets("order").Columns(mf).EntireColumn.Copy Columns(mt1 & ":" & cn(CLng(mt) + rcs - 1))
        Sheets("order").Columns(mf).EntireColumn.ClearContents

    End Select
Next i

'numberic NO
rs = Range("A65536").End(xlUp).Row
cs = Range("A1").End(xlToRight).Column
Cells(1, 1) = 0
For i = 2 To cs
    Cells(1, i) = i - 1
Next i
For i = 2 To rs
    Cells(i, 1) = i - 1
Next i

Sheets("order").Select

er:
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

二. 增加一自定义函数
Public Function cn(column_num As Integer) As String
          Dim z   As Integer
          Dim x   As Integer
          Dim arr(27)   As String
          For x = 1 To 26
              arr(x) = Chr(64 + x)
          Next

          z = Int((column_num - 0.5) / 26)
          If column_num > 26 Then
             cn = arr(z)
          End If

          z = column_num Mod 26
          If z = 0 Then
             cn = cn & arr(26)
          Else
             cn = cn & arr(z)
          End If
End Function

三. SelectionChange事件代码

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ss As Long

If Target.Column = 1 Then
   ss = Range("A65536").End(xlUp).Row
   If ss >= 2 Then
      [Button 1].Visible = True
   End If
   If ss < 2 Then
      [Button 1].Visible = False
   End If
End If

End Sub

EXCEL行移动和列移动vba

杂谈