Docstoc

函数 VBA-总表数据拆成分表名

Document Sample
函数 VBA-总表数据拆成分表名 Powered By Docstoc
					Sub Sortdata()    '按工作单位排序
    Dim i As Integer, row_d As Integer
    row_d = Sheets("总表").Range("A2").End(xlDown).Row
    right_end = Sheets("总表").Range("A1").End(xlToRight).Column
    Range(Cells(2, 1), Cells(row_d, right_end)).Select
    'Range("A2:L" & row_d).Select
    Selection.Sort Key1:=Range("C2"), Order1:=xlAscending, Header:=xlNo, _
          OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
          :=xlPinYin
End Sub


Sub sht_Name()     '筛选出总表中的单位个数和名称
    Dim i As Integer, row_d As Integer
    Dim mycell As Range
    Dim Nodupes As New Collection


    On Error Resume Next
    row_d = Sheets("总表").Range("C2").End(xlDown).Row
    For Each mycell In Sheets("总表").Range("C2:C" & row_d)
          Nodupes.Add mycell.Value, CStr(mycell.Value)
    Next mycell
    On Error GoTo 0
    i = 1
    For Each Item In Nodupes
          Sheets("总表").Cells(i, 78).Value = Item
          i = i + 1
    Next Item
End Sub


Sub Add_sht()    '根据筛选出的单位增加相应的工作表
    Dim i As Integer, Row_cnt As Integer
    Row_cnt = Application.WorksheetFunction.CountA(Sheets("总表").Range("BZ:BZ"))
    For i = 1 To Row_cnt
          Sheets.Add After:=ActiveSheet
          ActiveSheet.Name = Sheets("总表").Cells(i, 78).Value
    Next i
    Sheets("总表").Activate
End Sub


Sub Copy_head()    '复制表头
    Dim i As Integer, row_d As Integer, right_end As Integer
    row_d = Sheets("总表").Range("BZ1").End(xlDown).Row
    right_end = Sheets("总表").Range("A1").End(xlToRight).Column
    Sheets("总表").Select
    Range(Cells(1, 1), Cells(1, right_end)).Copy
    For i = 1 To row_d
          Sheets(Sheets("总表").Cells(i, 78).Value).Select
          Range(Cells(1, 1), Cells(1, right_end)).Select
          ActiveSheet.Paste
    Next i
End Sub


Sub Add_data(sht_Name)       '找出要取资料的区域
    Dim i As Integer, j As Integer, row_d As Integer
    Dim First_row As Integer, Last_row As Integer
    On Error Resume Next
    right_end = Sheets("总表").Range("A1").End(xlToRight).Column
    With Sheets("总表")
          i = 1
          Do Until .Cells(i, 3).Value = sht_Name
              i = i + 1
          Loop
          First_row = i


          j = First_row
          Do Until .Cells(j, 3) <> sht_Name
              j = j + 1
          Loop
          Last_row = j - 1
    End With
    Sheets("总表").Range(Cells(First_row, 1), Cells(Last_row, right_end)).Select
    Selection.Copy
    Sheets(sht_Name).Select
    Range("A2").Select
    ActiveSheet.Paste
    With ActiveSheet
          row_d = .Range("A2").End(xlDown).Row + 1
          Range("B" & row_d).Value = "合计"
          For i = 5 To right_end - 1
              Cells(row_d, i).Value = Application.WorksheetFunction.Sum(Range(Cells(2, i), Cells(row_d - 1, i)))
          Next i
          .Range(Cells(row_d, 1), Cells(row_d, right_end)).Select
          加格线
    End With


    Sheets("总表").Activate
    Range("A2").Select


End Sub


Sub Paste_date()     '将资料复制到相应的工作表
    Dim i As Integer, row_d As Integer
    On Error Resume Next
    Sheets("总表").Activate
    row_d = Sheets("总表").Range("BZ1").End(xlDown).Row
    For i = 1 To row_d
          Add_data (Sheets("总表").Cells(i, 78).Text)
    Next i
    Application.CutCopyMode = False
    Sheets("总表").Range("BZ:BZ").Delete
End Sub


Sub Finish()     '整个过程
    Sortdata
    sht_Name
    Add_sht
    Copy_head
    Paste_date
End Sub



Sub 加格线()
    'Range("A242:F242").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
          .LineStyle = xlContinuous
          .Weight = xlThin
          .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
          .LineStyle = xlContinuous
          .Weight = xlThin
          .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
          .LineStyle = xlContinuous
          .Weight = xlThin
          .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
          .LineStyle = xlContinuous
          .Weight = xlThin
          .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
          .LineStyle = xlContinuous
          .Weight = xlThin
          .ColorIndex = xlAutomatic
    End With
End Sub
修改拆分字段   修改字段限制   删除合计
, Cells(row_d - 1, i)))
序号    工作单位    姓名    合同起始时       www       合同终止时
 20   地质工程组   杨震    12/1/2002    345.00   11/30/2003
 22   地质工程组   邱青霞   12/1/2000    345.00   11/30/2003
 26   地质工程组   王亚清   12/1/2000    345.00   11/30/2003
 27   地质工程组   王莉莉   12/1/2000    345.00   11/30/2003
 30   地质工程组   李江涛   12/1/2002    345.00    无固定
  1   工区领导    冯书全   12/1/2000    345.00   11/30/2006
  2   工区领导    梁海龙   12/1/2000    345.00   11/30/2006


说明:1、要拆分项目必须放在C列。2、必须以数据库格式,表头放在首行。
          4、要拆分的表的工作表标签名必须为“总表”。
   3、字段最多不能超过77列。
104100100
 104110000

				
DOCUMENT INFO
Shared By:
Tags: excel
Stats:
views:9
posted:11/30/2012
language:Unknown
pages:16
201212 29 201212 29
About download professional profile