【VBA】通过VBA自动解析指定工作薄，生成自己需要的数据表

最近使用VBA自动处理EXCEL的数据，用着用着觉得很方便，于是写了一些小脚本，不过水平有限，代码很冗余。

个人使用的脚本一般都是符合个人使用的特定场景，不像高手写的有很强的复用性。

不过既然写了，方便了个人的同时，我还是抛砖引玉分享一下，万一能帮到人呢！同时自己也留个备忘。

这里主要是：传播一种使用脚本解决重复性、简单、单调工作时，主动去寻找使用脚本解决的思想。

本案例需求是将图2中的数据按照图四的样式展开，同时生成一个目录页，所以写了这个脚本用来一键生成。

附上脚本的一部分：

Sub lianjie() '在首页生成每个sheet页的超链接
Dim x As Long
x = 0
For x = 5 To Sheets.Count
Sheets(3).Select '我的首页设在第三页，所以选中第三页
Sheets(3).Hyperlinks.Add Anchor:=Cells(9 + x, 4), Address:=ActiveWorkbook.Name, SubAddress:=Sheets(x).Name & "!A1", TextToDisplay:=Sheets(x).Name
Next
End Sub

'写入表名，这里说一下使用场景，我需要从另个工作薄中获取每个sheet页（sheet页模板在我的<span style="font-size:12px;"><span class="link_title"><a target=_blank href="http://blog.csdn.net/zutsoft/article/details/45441343">EXCEL通过VBA生成SQL，自动生成创建表结构SQL</a></span></span> 博文里给出了）
'存在指定位置的数据库表名，每次手工一页一页复制很累，所以写个脚本同步过来
Sub Write_Tablename()
Dim x As Long '声明变量x，用来循环
str_source = ""
x = 0
For x = 5 To Sheets.Count
str_source = Trim(Sheets(3).Cells(9 + x, 5)) '获取源表名，源表名位于从第9行开始的第五列。
If str_source <> "" Then '如果源标记不为空
'截取前四位和元标记+‘_’对比
If Left(str_source, 4) = Trim(Sheets(3).Cells(11, 2)) & "_" Then  '从左边截取4位
str_temp = Mid(str_source, 5) '截取第5位到字符串尾
Else
str_temp = str_source
End If

str_target = "TS_" & Trim(Sheets(3).Cells(11, 2)) & "_" & str_temp '去除空格，生成“TS_源标记_表名”格式的ts层表名
str_mapping = LCase("m_" & Trim(Sheets(3).Cells(11, 2)) & "_ts_" & str_temp) '生成 “m_源标记_ts_表名” 格式的infamatica使用的mapping 名

Sheets(3).Cells(9 + x, 6) = str_target
Sheets(3).Cells(9 + x, 7) = str_mapping
Sheets(x).Cells(7, 3) = str_source
Sheets(x).Cells(7, 10) = str_target

End If
Next

 End Sub

'生成序号，图三中的序号
Sub create_index()
Dim line As Integer, sheet_index As Integer, index As Integer

For sheet_index = 5 To Sheets.Count
index = 1
For i = 0 To 200
If Trim(Sheets(sheet_index).Cells(10 + index, 9)) <> "" Then
Sheets(sheet_index).Select
Sheets(sheet_index).Cells(10 + index, 1) = index
Sheets(sheet_index).Cells(10 + index, 1).HorizontalAlignment = xlCenter '设置水平方向居中对齐
Sheets(sheet_index).Cells(10 + index, 1).VerticalAlignment = xlCenter   '垂直方向居中对齐
ActiveSheet.Range(Cells(11, 1), Cells(10 + index, 16)).Borders.LineStyle = 1 '将有数据的范围画上边框
ActiveSheet.Range(Cells(11, 8), Cells(10 + index, 8)).Merge '中间的列作为分割线，做合并处理
index = index + 1
End If
Next
Next
End Sub

'插入etl 使用的字段
Sub insert_etl_row()
Dim sheet_index As Integer, index As Integer

For sheet_index = 5 To Sheets.Count
index=0
 For i = 0 To 200
If Trim(Sheets(sheet_index).Cells(10 + index, 9)) <> "" Then
index = index + 1
End If
Next

  If Sheets(sheet_index).Cells(7 + index, 9) <> "C_SOURCENO" Then  '如果倒数第三行已经是C_SOURCENO，则不需要插入etl字段
Sheets(sheet_index).Cells(10 + index, 9) = "C_SOURCENO"
Sheets(sheet_index).Cells(10 + index, 10) = "采集源代码"
Sheets(sheet_index).Cells(10 + index, 11) = "N"
Sheets(sheet_index).Cells(10 + index, 12) = "C"
Sheets(sheet_index).Cells(10 + index, 13) = "2"

Sheets(sheet_index).Cells(11 + index, 9) = "D_DATADATE"
Sheets(sheet_index).Cells(11 + index, 10) = "数据日期"
Sheets(sheet_index).Cells(11 + index, 11) = "N"
Sheets(sheet_index).Cells(11 + index, 12) = "D"
Sheets(sheet_index).Cells(11 + index, 13) = "8"

Sheets(sheet_index).Cells(12 + index, 9) = "C_ROWFLAG"
Sheets(sheet_index).Cells(12 + index, 10) = "行标志"
Sheets(sheet_index).Cells(12 + index, 11) = "N"
Sheets(sheet_index).Cells(12 + index, 12) = "C"
Sheets(sheet_index).Cells(12 + index, 13) = "1"

End If
Next
End Sub

'一键同步源表数据，做一定的转换，生成我需要的数据表格式
Sub Create_TableFrame()
Dim x As Long
str_temp = ""
x = 0
worksheetname = "平台表结构设计.xls"
If WorkbookOpen(worksheetname) Then '判断需要读取的工作薄是否打开，未打开则提示需要打开。

For x = 2 To Workbooks(worksheetname).Sheets.Count '源表工作表循环

'获取表名
str_temp = Workbooks(worksheetname).Sheets(x).Cells(3, 3) '获取另一个数据表的sheet页的第3行第3列
Sheets(3).Cells(12 + x, 5) = str_temp '将值付给当前活动sheet页里的指定位置

str_sheet_name = Workbooks(worksheetname).Sheets(x).Name '获取另一个数据表的sheet页的名字

If str_sheet_name <> "" Then '如果sheet名不为空
'生成sheet页
Sheets("模板").Copy After:=Worksheets(Worksheets.Count) '复制并新建sheet页，将sheet排在当前工作表的最后面（实质是一个接一个的排列在后面）
ActiveSheet.Name = str_sheet_name '重命名复制的sheet页
'填写接口名称
ActiveSheet.Cells(2, 3) = str_sheet_name
str_sheet_name = ""
'获取主键
ActiveSheet.Cells(8, 3) = Workbooks(worksheetname).Sheets(x).Cells(5, 3)
ActiveSheet.Cells(8, 10) = Workbooks(worksheetname).Sheets(x).Cells(5, 3)

For i = 2 To 100
'获取字段
line_temp = Workbooks(worksheetname).Sheets(x).Cells(13 + i, 2)
If line_temp <> "" Then
ActiveSheet.Cells(9 + i, 2) = line_temp
ActiveSheet.Cells(9 + i, 9) = line_temp
'获取类型
type_temp = Workbooks(worksheetname).Sheets(x).Cells(13 + i, 3)

'数据类型的处理
pos1 = 0
data_temp = UCase(Trim(type_temp))
If data_temp <> "" Then
pos1 = InStr(1, data_temp, "(")
If pos1 = 0 Then
str_type = "DATE"
Else
str_type = Left(data_temp, pos1 - 1)
str_num = Mid(data_temp, pos1 + 1)
str_num = Replace(str_num, ")", "")
End If

Select Case str_type
Case "VARCHAR2"
ActiveSheet.Cells(9 + i, 5) = "VC"
ActiveSheet.Cells(9 + i, 6) = str_num

Case "NUMBER"
ActiveSheet.Cells(9 + i, 5) = "N"
pos2 = InStr(1, str_num, ",")
If pos2 = 0 Then
ActiveSheet.Cells(9 + i, 6) = str_num
Else
ActiveSheet.Cells(9 + i, 6) = Left(str_num, pos2 - 1)

ActiveSheet.Cells(9 + i, 7) = Mid(str_num, pos2 + 1)
End If

Case "CHAR"
ActiveSheet.Cells(9 + i, 5) = "C"
ActiveSheet.Cells(9 + i, 6) = str_num
Case "DATE"
ActiveSheet.Cells(9 + i, 5) = "D"
Case Default
data_temp = "error"  '只要上面未匹配就认为错误
End Select
End If '数据类型处理完毕

'是否为空
ActiveSheet.Cells(9 + i, 4) = Workbooks(worksheetname).Sheets(x).Cells(13 + i, 4)
'获取中文解释
ActiveSheet.Cells(9 + i, 3) = Workbooks(worksheetname).Sheets(x).Cells(13 + i, 6)
ActiveCell.EntireRow.AutoFit
ActiveSheet.Cells(9 + i, 10) = Workbooks(worksheetname).Sheets(x).Cells(13 + i, 6)
ActiveCell.EntireRow.AutoFit

'是源表的字段复制到映射的目标表字段同步
ActiveSheet.Cells(9 + i, 11) = ActiveSheet.Cells(9 + i, 4)
ActiveSheet.Cells(9 + i, 12) = ActiveSheet.Cells(9 + i, 5)
ActiveSheet.Cells(9 + i, 13) = ActiveSheet.Cells(9 + i, 6)
ActiveSheet.Cells(9 + i, 14) = ActiveSheet.Cells(9 + i, 7)
End If '字段名不为空
Next '循环1 to 100 每页假设有100个字段
End If '如果sheet名不为空
Next '源表工作表循环

'调用之前的函数，达到一键生成的目的
Call VBAProject.模块3.insert_etl_row
Call VBAProject.模块3.create_index
'生成超链接时，是页面回到目录页，我的工作表的第三页
Sheets(3).Select
Call VBAProject.模块3.Write_Tablename
Call VBAProject.模块3.lianjie
'提示信息
MsgBox "同步成功"
Else
MsgBox "请打开" & worksheetname & "！"
End If

End Sub

Function WorkbookOpen(ByVal WorkBookName As String) As Boolean
'如果该工作簿已打开则返回真
WorkbookOpen = False
On Error GoTo WorkBookNotOpen
If Len(Application.Workbooks(WorkBookName).Name) > 0 Then
WorkbookOpen = True
'MsgBox "该工作簿已打开"
Exit Function
End If
WorkBookNotOpen:
End Function

目录页格式如图1：



需要同步数据的表格式如图2：



同步过来生成的结果如图3：


映射标的模板如图4：