Excel转换
昨天在百度搜索资料的时候，看到一个关于Excel信息排版转换的提问。于是自己动手用VB写了一个算法。
提问者的大体描述为：
Excel中的原始信息排版如下：
公司名称 123
产品 123
简介
联系方式 123
邮件 123
公司名称 123
产品 123
简介
联系方式 123
邮件 123
。。。。。。
预想的Excel排版如下：
公司名称 产品 简介 联系方式 邮件
123 1213 12 123 12
123 1213 12 123 12
123 1213 12 123 12
123 1213 12 123 12
假设：原始信息中所有信息存放在第一个工作表中，且只有两列，一列为项目名（不可以为空值），另一列为项目值，且每组信息的项目名一样，即列一以（公司名称 产品 简介 联系方式 邮件。。。）的形式重复出现。
分析：首先获取原始Excel文件；然后获取列项目名的数量，确定新的Excel的第一行；接着循环读取原始信息中列2的值存放在新表中
关键代码如下：
Dim objExl As New Excel.Application
Dim lie As Integer
Dim i, j, t, Num As Integer
objExl.Workbooks.Open (dlg.FileName) '通过读取通用对话框获取的文件名打开Excel原始文件
'在原始文件中创建一个新的工作表，存放转换后的信息
objExl.Worksheets.Add , objExl.Sheets(objExl.Sheets.Count)
Num = objExl.Sheets.Count
objExl.Sheets(Num).Name = "转换后"
objExl.Sheets(1).Select '选定原始文件
For i = 2 To 20 '假设最多的项目名为20个，实现实际项目名的获取
If objExl.Cells(i, 1) = objExl.Cells(1, 1) Then
Exit For
End If
Next i
lie = i - 1
For i = 1 To lie '确定了项目名的个数，读取原始表中的项目名依次拷贝到新的工作表中
objExl.Sheets(1).Cells(i, 1).Copy
objExl.Sheets(Num).Select
objExl.Sheets(Num).Cells(1, i).Select
objExl.ActiveSheet.Paste
objExl.Sheets(1).Select
Next i
i = 1
j = 1
t = 2 '新的工作表中从第二行起始实现项目值的拷贝
Do While objExl.Sheets(1).Cells(i, 1) <> "" '项目名以空值为结束标志
objExl.Sheets(1).Cells(i, 2).Copy
objExl.Sheets(Num).Select
objExl.Sheets(Num).Cells(t, j).Select
objExl.ActiveSheet.Paste
If (j Mod lie = 0) Then '以每一项目组为标志，实现新工作表中的换行操作
t = t + 1
j = 0
End If
j = j + 1
i = i + 1
objExl.Sheets(1).Select
Loop
objExl.Visible = True
objExl.Sheets(Num).Select '设置Excel为可见，并选定新工作表，以便用户的查看
objExl.Quit
在此附上生成的小应用程序和供测试的文本。
