vba拆分excel表格

上一个星期在做数学建模，由于要拆分和计算一个60M的excel表格，写了几个代码和大家分享

2-1拆分代码

Sub Macro2()

'
' 拆分一号机
'


'
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim day As Integer
    Dim counter As Integer
    Dim counter2 As Integer
    Dim filename As String
    Dim daystr As String
    For counter = 1 To 10
        counter2 = 0 + counter
        filename = "G:\电工杯\2\一号机\01"
        Application.Goto Reference:="R4C" + LTrim(Str(counter2)) + ":R51844C" + LTrim(Str(counter2))
        Selection.Copy
        Workbooks.Add
        Range("A4").Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        i = counter 
        day = i
        daystr = LTrim(day)
        Range("A5").Select
        If day < 10 Then
        daystr = "0" + daystr
        End If
        ActiveWorkbook.SaveAs filename:=filename + daystr + ".xls", _
            FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=False
        ActiveWindow.Close
       
    Next counter

end sub

2-2计算方差和功率代码

Sub Macro1()
'
' Macro1 Macro
'


'
    Dim counter As Integer
    Dim i As Long
    Dim columnnum As Integer
    Dim datanum As String
    Dim filenamepro As String
    For counter = 1 To 10


        
        filenamepro = "G:\电工杯\2\一号机\01"
        datanum = LTrim(Str(counter))
        If counter < 10 Then
        datanum = "0" + datanum
        End If
        Workbooks.Open filename:=filenamepro + datanum + ".xls"
        Cells.Select
        Selection.Copy
        Workbooks.Add
        Cells.Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
            Dim startnum As Long
            For i = 1 To 100
                Range("B" + LTrim(Str(4 + i))).Select
                startnum = 5 + (i - 1) * 12
                ActiveCell.FormulaR1C1 = "=AVERAGE(R" + LTrim(Str(startnum)) + "C1:R" + LTrim(Str(startnum + 11)) + "C1)"
            Next i
        ActiveWorkbook.SaveAs filename:=filenamepro + datanum + "DATA" + ".xls", _
            FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=False


            For i = 100 To 4320
                Range("B" + LTrim(Str(4 + i))).Select
                startnum = 5 + (i - 1) * 12
                ActiveCell.FormulaR1C1 = "=AVERAGE(R" + LTrim(Str(startnum)) + "C1:R" + LTrim(Str(startnum + 11)) + "C1)"
                If (i Mod 100) = 0 Then
                    ActiveWorkbook.Save
                End If
            Next i
            Range("C5").Select
            ActiveCell.FormulaR1C1 = "=VAR(R5C2:R4324C2)"
            ActiveWorkbook.Save
        ActiveWindow.Close
        ActiveWindow.Close
    Next counter
End Sub












































































































































Sub Macro1()
'
' Macro1 Macro
'


'
    Dim counter As Integer
    Dim i As Long
    Dim columnnum As Integer
    Dim datanum As String
    Dim filenamepro As String
    For counter = 1 To 10


        
        filenamepro = "G:\电工杯\2\五号机\05"
        datanum = LTrim(Str(counter))
        If counter < 10 Then
        datanum = "0" + datanum
        End If
        Workbooks.Open filename:=filenamepro + datanum + ".xls"
        Cells.Select
        Selection.Copy
        Workbooks.Add
        Cells.Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
            Dim startnum As Long


            For i = 1 To 4320
                Range("B" + LTrim(Str(4 + i))).Select
                startnum = 5 + (i - 1) * 12
                ActiveCell.FormulaR1C1 = "=AVERAGE(R" + LTrim(Str(startnum)) + "C1:R" + LTrim(Str(startnum + 11)) + "C1)"
            Next i


            ActiveWorkbook.SaveAs filename:=filenamepro + datanum + "DATA" + ".xls", _
            FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=False




            Range("C5").Select
            ActiveCell.FormulaR1C1 = "=VAR(R5C2:R4324C2)"
            ActiveWorkbook.Save
        ActiveWindow.Close
        ActiveWindow.Close
    Next counter
End Sub

2-3均值方差列拆分拆分代码

Sub Macro2()
'
' Macro2 Macro
    Dim counter As Integer
    Dim i As Integer
    Dim columnnum As Integer
    Dim datanum As String
    Dim filenamepro As String


    ChDir "G:\电工杯\2\一号机"
    For counter = 1 To 10
        filenamepro = "G:\电工杯\2\一号机\01"
        datanum = LTrim(Str(counter))
        If counter < 10 Then
        datanum = "0" + datanum
        End If


        Workbooks.Open filename:=filenamepro + datanum + "DATA" + ".xls"
        Columns("B:B").Select
        Selection.Copy
        Workbooks.Add
        Columns("A:A").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Range("A4").Select
        Application.CutCopyMode = False
        ActiveCell.FormulaR1C1 = "平均功率"
        Range("C4").Select
        ActiveWorkbook.SaveAs filename:=filenamepro + datanum + "DATA平均功率" + ".xls", FileFormat _
            :=xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
            False, CreateBackup:=False
        ActiveWindow.Close
        Columns("C:C").Select
        Selection.Copy
        Workbooks.Add
        Columns("A:A").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Range("A4").Select
        Application.CutCopyMode = False
        ActiveCell.FormulaR1C1 = "方差"
        ActiveWorkbook.SaveAs filename:=filenamepro + datanum + "DATA方差" + ".xls", FileFormat:= _
            xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
            , CreateBackup:=False
        ActiveWindow.Close
        ActiveWindow.Close
   Next counter
End Sub

4-1-1分钟拆分代码

Sub Macro1()
'
' 1分钟
'


'
    Dim counter As Integer
    Dim i As Long
    Dim columnnum As Integer
    Dim datanum As String
    Dim filenamepro As String
    For counter = 1 To 10


        
        filenamepro = "G:\电工杯\第四题\拆分\"
        datanum = LTrim(Str(counter))
        If counter < 10 Then
        datanum = "0" + datanum
        End If
        Workbooks.Open filename:=filenamepro + "拆分"+datanum + ".xls"
        Cells.Select
        Selection.Copy
        Workbooks.Add
        Cells.Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
            Dim startnum As Long


            For i = 1 To 4320
                Range("B" + LTrim(Str(0 + i))).Select
                startnum = 1 + (i - 1) * 12
                ActiveCell.FormulaR1C1 = "=R" + LTrim(Str(startnum)) + "C1"
            Next i


            ActiveWorkbook.SaveAs filename:=filenamepro + "1分钟拆分\1M"+datanum + "DATA" + ".xls", _
            FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=False




            Range("C1").Select
            ActiveCell.FormulaR1C1 = "=VAR(R1C2:R4320C2)"
            ActiveWorkbook.Save
        ActiveWindow.Close
        ActiveWindow.Close
    Next counter
End Sub

4-1拆分代码

Sub Macro2()
'
' 拆分
'


'
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim day As Integer
    Dim counter As Integer
    Dim counter2 As Integer
    Dim filename As String
    Dim daystr As String
    For counter = 1 To 10
        counter2 = 0 + counter
        filename = "G:\电工杯\第四题\拆分\拆分"
        Application.Goto Reference:="R1C" + LTrim(Str(counter2)) + ":R51840C" + LTrim(Str(counter2))
        Selection.Copy
        Workbooks.Add
        Range("A1").Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        i = counter 
        day = i
        daystr = LTrim(day)
        If day < 10 Then
        daystr = "0" + daystr
        End If
        ActiveWorkbook.SaveAs filename:=filename + daystr + ".xls", _
            FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=False
        ActiveWindow.Close
       
    Next counter


end sub



1000个数据变成125行

这个代码好像删了



















































































Sub Macro1()
'
' 5分钟
'


'
    Dim counter As Integer
    Dim i As Long
    Dim columnnum As Integer
    Dim datanum As String
    Dim filenamepro As String
    For counter = 1 To 10


        
        filenamepro = "G:\电工杯\第四题\拆分\"
        datanum = LTrim(Str(counter))
        If counter < 10 Then
        datanum = "0" + datanum
        End If
        Workbooks.Open filename:=filenamepro + "拆分"+datanum + ".xls"
        Cells.Select
        Selection.Copy
        Workbooks.Add
        Cells.Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
            Dim startnum As Long


            For i = 1 To 864
                Range("B" + LTrim(Str(0 + i))).Select
                startnum = 1 + (i - 1) * 60
                ActiveCell.FormulaR1C1 = "=R" + LTrim(Str(startnum)) + "C1"
            Next i


            ActiveWorkbook.SaveAs filename:=filenamepro + "5分钟拆分\5M"+datanum + "DATA" + ".xls", _
            FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=False




            Range("C1").Select
            ActiveCell.FormulaR1C1 = "=VAR(R1C2:R864C2)"
            ActiveWorkbook.Save
        ActiveWindow.Close
        ActiveWindow.Close
    Next counter
End Sub














































































































Sub Macro1()
'
' 15分钟
'


'
    Dim counter As Integer
    Dim i As Long
    Dim columnnum As Integer
    Dim datanum As String
    Dim filenamepro As String
    For counter = 1 To 10


        
        filenamepro = "G:\电工杯\第四题\拆分\"
        datanum = LTrim(Str(counter))
        If counter < 10 Then
        datanum = "0" + datanum
        End If
        Workbooks.Open filename:=filenamepro + "拆分"+datanum + ".xls"
        Cells.Select
        Selection.Copy
        Workbooks.Add
        Cells.Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
            Dim startnum As Long


            For i = 1 To 288
                Range("B" + LTrim(Str(0 + i))).Select
                startnum = 1 + (i - 1) * 180
                ActiveCell.FormulaR1C1 = "=R" + LTrim(Str(startnum)) + "C1"
            Next i


            ActiveWorkbook.SaveAs filename:=filenamepro + "15分钟拆分\15M"+datanum + "DATA" + ".xls", _
            FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=False




            Range("C1").Select
            ActiveCell.FormulaR1C1 = "=VAR(R1C2:R288C2)"
            ActiveWorkbook.Save
        ActiveWindow.Close
        ActiveWindow.Close
    Next counter
End Sub