用VBA處理Excel

1、Excel中多個工作結構一樣的工作表合併到一個表中

Sub yy()
Sheets.Add after:=Sheets(Sheets.Count) '新建一個工作表放在最後
For i = 2 To Sheets.Count - 1 '從第一個工作表到倒數第二個工作表
With Sheets(i)
n = .[c65536].End(xlUp).Row '分別求出最大行號
.Range("a2:V" & n).Copy ActiveSheet.[c65536].End(xlUp).Offset(1, -2) '取a2開始到最後的數據copy到新表數據的下一行。
End With
    Next
End Sub
 

2、根據表中的某個字段，將現在的某個工作表按字段分開到不同的文本中

'====================================================================================
'南區根據移動要求分成多文件模板
'時間：2007-07-17
'作者：uwen
'使用說明：1、要分開的工作表必須放在工作薄的第一個表的位置
'          2、選擇要用來作爲文件名的字段的列所在的序號，寫在字段的後面
'          3、選擇要輸出的列數的數目以及輸出列的序號
'====================================================================================

Sub test()
   
    Dim TotalTable As String                        '總表,此處要替換過來
    TotalTable = "Sheet1"                           '  此處要替換過來
   
   
    Dim strFileNameField As Integer                 '要作爲到處後文件命名的字段在表中的列
    strFileNameField = 5                            '  要根據實際情況替換
   
    Const OutPutColNum = 3                           '輸出列數,需要根據需要重新填寫
   
    Dim OutPutCols(OutPutColNum) As Integer         '輸出的列數組
    OutPutCols(0) = 8                               '輸出的列
    OutPutCols(1) = 9                               '輸出的列
    OutPutCols(2) = 10                              '輸出的列
   
   
    Dim CLL As Range, TotalWS As Worksheet, PartWS As Worksheet, flag As Boolean, tmpSheetName As String, j As Integer
   
    Application.ScreenUpdating = False
    Set TotalWS = Sheets(TotalTable)
    j = 0
   
    For Each CLL In TotalWS.Range("A2", TotalWS.Cells(TotalWS.Rows.Count, 1).End(xlUp))
        flag = False
       
        tmpSheetName = Trim(UCase(TotalWS.Rows.Cells(CLL.Row, strFileNameField)))
       
        For Each ws In Worksheets
            If Trim(UCase(ws.Name)) <> Trim(UCase(TotalTable)) Then
                If Trim(UCase(ws.Name)) = tmpSheetName Then
                    flag = True
                    Set PartWS = Sheets(tmpSheetName)
                    If Not PartWS Is Nothing Then
                        CLL.EntireRow.Copy PartWS.Rows(PartWS.UsedRange.Rows.Count + 1)
                    End If
                    Set PartWS = Nothing
            End If
            If flag = True Then Exit For
            End If
        Next
        If flag = False Then
            j = j + 1
            Worksheets.Add(After:=TotalWS).Name = tmpSheetName
            'TotalWS.Rows(1).Copy Sheets(tmpSheetName).Rows(1)
            flag = True
            Set PartWS = Sheets(tmpSheetName)
            'If Not PartWS Is Nothing Then
                CLL.EntireRow.Copy PartWS.Rows(PartWS.UsedRange.Rows.Count)
            'End If
            Set PartWS = Nothing
        End If
    Next
   
    Dim s As String
    Dim FullName As String, rng As Range
   
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        '將所有表的內容輸出到文本文件
         If Trim(UCase(ws.Name)) <> Trim(UCase(TotalTable)) Then
            FullName = (ThisWorkbook.Path) & "/" & Trim(UCase(ws.Name)) & ".txt" '以當前表名爲TXT文件名
            Open FullName For Output As #1    '以讀寫方式打開文件，每次寫內容都會覆蓋原先的內容
            '參考幫助，fullname爲文件全名
            Dim i As Integer
            i = 0
            For Each rng In Range("a1").CurrentRegion
                flag = False
                For i = 0 To UBound(OutPutCols)
                    If (rng.Column = OutPutCols(i)) Then flag = True
                Next
               
                If flag = True Then
                    's = s & IIf(s = "", "", Chr(9)) & rng.Value & "|"
                    s = s & IIf(s = "", "", "|") & rng.Value
                End If
                If rng.Column = Range("a1").CurrentRegion.Columns.Count Then
                    Print #1, s             '把數據寫到文本文件裏
                    'Print #1, s & Chr(9)   '把數據寫到文本文件裏
                    s = ""
                End If
            Next
            Close #1    '關閉文件
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub