一个拆分数据表的小案例，将混合表按国别拆分为多张数据表，并做一个简单的汇总工作。虽然代码不长，但最近vba用的不多，很多代码知道实现逻辑，但就是忘记了书写的格式，记录一下测试流程，方便查询。另外，简单功能active控件就能够满足要求，就先不要用自定义窗体了，光是让窗体打开数据表自动运行，就又多一道工序。
vba中的数组
定义一个整型数组
Dim array(3) As Integer ' 定义一个大小为4的数组，索引为0到3
array(3) = 10 ' 正确使用索引3来赋值定义一个字符串数组
Dim strArray() As String
ReDim strArray(3) ' 定义一个长度为4的数组，索引从0到3
strArray(0) = "Apple"
strArray(1) = "Banana"
strArray(2) = "Cherry"
strArray(3) = "Date"判断是否已存在分表
Public Function SheetExists(sName As String) As Boolean
On Error GoTo ErrHandler
Dim sht As Worksheet
Set sht = ThisWorkbook.Sheets(sName)
SheetExists = True
Exit Function
ErrHandler:
SheetExists = False
End Function如不存在则创建新表
Public Function NewSheet(sName As String)
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = sName
End Function如已有表格则清空
Sub ClearWorksheetData()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") ' 将Sheet1替换为你要清除数据的工作表名字
ws.UsedRange.ClearContents ' 清除工作表中的数据
Set ws = Nothing
End Sub整合并拆表
Sub splitSheet()
Dim Country As String
Dim Count
CountryArray = Array("美国站", "德国站", "法国站", "意大利站", "比利时站", "荷兰站", "加拿大站", "英国站", "墨西哥站", "土耳其站", "瑞典站", "日本站", "波兰站")
'新建表格
For i = 0 To 12
Country = CountryArray(i)
If SheetExists(Country) Then
Else: NewSheet (Country)
End If
Next i
'清理数据
For i = 0 To 12
Country = CountryArray(i)
If SheetExists(Country) Then ClearWorksheetData (Country)
End If
Next i
'拆分数据
For i = 0 To 12
Count = 3
Country = CountryArray(i)
If Country = "美国站" Or Country = "英国站" Or Country = "加拿大站" Then
For j = 2 To 10240
If j = 2 Then
For k = 2 To 100
Sheets(Country).Cells(j, k) = Sheets(1).Cells(j, k)
Next k
ElseIf Country = "美国站" And Sheets(1).Cells(j, 3) = "美元" Or Sheets(1).Cells(j, 3) = Country Then
For k = 0 To 3
For l = 2 To 100
Sheets(Country).Cells(Count, l) = Sheets(1).Cells(j, l)
Next l
Count = Count + 1
j = j + 1
Next k
ElseIf Country = "英国站" And Sheets(1).Cells(j, 3) = "英镑" Or Sheets(1).Cells(j, 3) = Country Then
For k = 0 To 3
For l = 2 To 100
Sheets(Country).Cells(Count, l) = Sheets(1).Cells(j, l)
Next l
Count = Count + 1
j = j + 1
Next k
ElseIf Country = "加拿大站" And Sheets(1).Cells(j, 3) = "加元" Or Sheets(1).Cells(j, 3) = Country Then
For k = 0 To 3
For l = 2 To 100
Sheets(Country).Cells(Count, l) = Sheets(1).Cells(j, l)
Next l
Count = Count + 1
j = j + 1
Next k
End If
Next j
Else
For j = 2 To 10240
If j = 2 Then
For k = 2 To 100
Sheets(Country).Cells(j, k) = Sheets(1).Cells(j, k)
Next k
ElseIf Sheets(1).Cells(j, 3) = Country Then
For k = 0 To 3
For l = 2 To 100
Sheets(Country).Cells(Count, l) = Sheets(1).Cells(j, l)
Next l
Count = Count + 1
j = j + 1
Next k
End If
Next j
End If
Next i
End Sub
Public Function ClearWorksheetData(sName As String) '清理工作表
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(sName)
ws.UsedRange.ClearContents
Set ws = Nothing
End Function
Public Function NewSheet(sName As String) '新建工作表
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = sName
End Function
Public Function SheetExists(sName As String) As Boolean '判断表单是否已存在
On Error GoTo ErrHandler
Dim sht As Worksheet
Set sht = ThisWorkbook.Sheets(sName)
SheetExists = True
Exit Function
ErrHandler:
SheetExists = False
End Function绑定active按钮控件
Private Sub CommandButton1_Click()
Run splitSheet
End Sub
Public Function splitSheet()
Dim Country As String
Dim Count
CountryArray = Array("美国站", "德国站", "法国站", "意大利站", "比利时站", "荷兰站", "加拿大站", "英国站", "墨西哥站", "土耳其站", "瑞典站", "日本站", "波兰站")
'新建表格
For i = 0 To 12
Country = CountryArray(i)
If SheetExists(Country) Then
Else: NewSheet (Country)
End If
Next i
'清理数据
For i = 0 To 12
Country = CountryArray(i)
If SheetExists(Country) Then ClearWorksheetData (Country)
Next i
'拆分数据
For i = 0 To 12
Count = 3
Country = CountryArray(i)
If Country = "美国站" Or Country = "英国站" Or Country = "加拿大站" Then
For j = 2 To 10240
If j = 2 Then
For k = 2 To 100
Sheets(Country).Cells(j, k) = Sheets(1).Cells(j, k)
Next k
ElseIf Country = "美国站" And Sheets(1).Cells(j, 3) = "美元" Or Sheets(1).Cells(j, 3) = Country Then
For k = 0 To 3
For l = 2 To 100
Sheets(Country).Cells(Count, l) = Sheets(1).Cells(j, l)
Next l
Count = Count + 1
j = j + 1
Next k
ElseIf Country = "英国站" And Sheets(1).Cells(j, 3) = "英镑" Or Sheets(1).Cells(j, 3) = Country Then
For k = 0 To 3
For l = 2 To 100
Sheets(Country).Cells(Count, l) = Sheets(1).Cells(j, l)
Next l
Count = Count + 1
j = j + 1
Next k
ElseIf Country = "加拿大站" And Sheets(1).Cells(j, 3) = "加元" Or Sheets(1).Cells(j, 3) = Country Then
For k = 0 To 3
For l = 2 To 100
Sheets(Country).Cells(Count, l) = Sheets(1).Cells(j, l)
Next l
Count = Count + 1
j = j + 1
Next k
End If
Next j
Else
For j = 2 To 10240
If j = 2 Then
For k = 2 To 100
Sheets(Country).Cells(j, k) = Sheets(1).Cells(j, k)
Next k
ElseIf Sheets(1).Cells(j, 3) = Country Then
For k = 0 To 3
For l = 2 To 100
Sheets(Country).Cells(Count, l) = Sheets(1).Cells(j, l)
Next l
Count = Count + 1
j = j + 1
Next k
End If
Next j
End If
Next i
End Function
Public Function ClearWorksheetData(sName As String) '清理工作表
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(sName)
ws.UsedRange.ClearContents
Set ws = Nothing
End Function
Public Function NewSheet(sName As String) '新建工作表
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = sName
End Function
Public Function SheetExists(sName As String) As Boolean '判断表单是否已存在
On Error GoTo ErrHandler
Dim sht As Worksheet
Set sht = ThisWorkbook.Sheets(sName)
SheetExists = True
Exit Function
ErrHandler:
SheetExists = False
End Function最后简单进行汇总
总结数据未进行比对操作，后续需改进。
Private Sub CommandButton1_Click()
Run splitSheet
End Sub
Public Function splitSheet()
Dim Country As String
Dim Count As Integer
Dim ResArr(12) As Integer
CountryArray = Array("美国站", "德国站", "法国站", "意大利站", "比利时站", "荷兰站", "加拿大站", "英国站", "墨西哥站", "土耳其站", "瑞典站", "日本站", "波兰站")
'新建表格;
For i = 0 To 12
Country = CountryArray(i)
If SheetExists(Country) Then
Else: NewSheet (Country)
End If
Next i
'清理数据;
For i = 0 To 12
Country = CountryArray(i)
If SheetExists(Country) Then ClearWorksheetData (Country)
Next i
'拆分数据,注意 "cells" 函数的参数先行后列;
For i = 0 To 12
Count = 3
Country = CountryArray(i)
If Country = "美国站" Or Country = "英国站" Or Country = "加拿大站" Then
For j = 2 To 10240
If j = 2 Then
For k = 2 To 100
Sheets(Country).Cells(j, k) = Sheets(1).Cells(j, k)
Next k
ElseIf Country = "美国站" And Sheets(1).Cells(j, 3) = "美元" Or Sheets(1).Cells(j, 3) = Country Then
For k = 0 To 3
For l = 2 To 100
Sheets(Country).Cells(Count, l) = Sheets(1).Cells(j, l)
Next l
Count = Count + 1
j = j + 1
Next k
j = j - 1
ElseIf Country = "英国站" And Sheets(1).Cells(j, 3) = "英镑" Or Sheets(1).Cells(j, 3) = Country Then
For k = 0 To 3
For l = 2 To 100
Sheets(Country).Cells(Count, l) = Sheets(1).Cells(j, l)
Next l
Count = Count + 1
j = j + 1
Next k
ElseIf Country = "加拿大站" And Sheets(1).Cells(j, 3) = "加元" Or Sheets(1).Cells(j, 3) = Country Then
For k = 0 To 3
For l = 2 To 100
Sheets(Country).Cells(Count, l) = Sheets(1).Cells(j, l)
Next l
Count = Count + 1
j = j + 1
Next k
j = j - 1
End If
Next j
'根据Count的值添加统计;
SumResult Count, Country
Else
For j = 2 To 10240
If j = 2 Then
For k = 2 To 100
Sheets(Country).Cells(j, k) = Sheets(1).Cells(j, k)
Next k
ElseIf Sheets(1).Cells(j, 3) = Country Then
For k = 0 To 3
For l = 2 To 100
Sheets(Country).Cells(Count, l) = Sheets(1).Cells(j, l)
Next l
Count = Count + 1
j = j + 1
Next k
j = j - 1
End If
Next j
'根据Count的值添加统计;
SumResult Count, Country
End If
ResArr(i) = Count
Next i
If SheetExists("汇总表格") Then
ClearWorksheetData ("汇总表格")
Else:
NewSheet ("汇总表格")
End If
For i = 2 To 100
Sheets("汇总表格").Cells(1, i) = Sheets(1).Cells(2, i)
Next i
For i = 0 To 12
Country = CountryArray(i)
Sheets("汇总表格").Cells(i + 2, 1) = Country
For j = 2 To 100
Sheets("汇总表格").Cells(i + 2, j) = Sheets(Country).Cells(ResArr(i), j)
Next j
Next i
Sheets("汇总表格").Cells(15, 1) = "综合汇总"
For i = 6 To 100
If Sheets("汇总表格").Cells(2, i) <> "" Then
For j = 2 To 14
Sheets("汇总表格").Cells(15, i) = Sheets("汇总表格").Cells(15, i) + Sheets("汇总表格").Cells(j, i)
Next j
End If
Next i
End Function
Public Function ClearWorksheetData(sName As String) '清理工作表函数
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(sName)
ws.UsedRange.ClearContents
Set ws = Nothing
End Function
Public Function NewSheet(sName As String) '新建工作表函数
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = sName
End Function
Public Function SumResult(iNum As Integer, sName As String) '统计函数
Dim StartPoint As Integer
Sheets(sName).Cells(iNum, 3) = "汇总数据"
If sName = "美国站" Then
StartPoint = 9
Else
StartPoint = 5
End If
For i = 6 To 100
If Sheets(sName).Cells(StartPoint, i) <> "" Then Sheets(sName).Cells(iNum, i) = Sheets(sName).Cells(StartPoint, i) - Sheets(sName).Cells(StartPoint + 4, i) - Sheets(sName).Cells(StartPoint + 8, i) - Sheets(sName).Cells(StartPoint + 12, i) - Sheets(sName).Cells(StartPoint + 16, i)
Next i
End Function
Public Function SheetExists(sName As String) As Boolean '判断表单函数
On Error GoTo ErrHandler
Dim sht As Worksheet
Set sht = ThisWorkbook.Sheets(sName)
SheetExists = True
Exit Function
ErrHandler:
SheetExists = False
End Function