Office中国论坛/Access中国论坛

标题: 自己已解决:交叉2DExcel表格如何导入到Access数据表中 [打印本页]

作者: supperboy 时间: 2010-11-9 13:37
标题: 自己已解决:交叉2DExcel表格如何导入到Access数据表中
本帖最后由 supperboy 于 2010-11-12 09:36 编辑

我有一张excel表格,想要导入到Access数据库中,但是由于表格的特殊性,实在不知如何是好,请各位老师帮我一下啊,表格如下:

颜色1 颜色2 颜色3 颜色4
尺码白色黑色红色绿色
X    21    32             12
XL    24             21    5
SS             34    43 12
M    13    35    23 12

想要的数据库表,表事先在Access库中建立好的:

尺码颜色数量
X 白色 21
X 黑色 32
X 绿色 12
XL  白色 24
XL  红色 21
XL  绿色 5

以此类推,请大家帮我一下,并且其中没有数量的单元格该如何判断,谢谢!

作者: pureshadow 时间: 2010-11-9 16:39
在ACC里怎么折腾我不知道，不过在E里，倒是可以先转换一下的。
尺码列：=INDIRECT("a"&INT(ROW(A8)/4))下拉，如果颜色有十种，那就改成INDIRECT("a"&INT(ROW(A20)/10))
颜色列：=INDIRECT("r1c"&MOD(ROW(A4),4)+2,)，如果尺码有10种，那就改成INDIRECT("r1c"&MOD(ROW(A10),10)+2,)
数量列：=SUMPRODUCT((A$2:A$5=A11)*(B$1:E$1=B11)*B$2:E$5)（按你第一个表，尺码在A1单元格写的，公式中的A11是对应的尺码，B11是对应的颜色。
[attach]44049[/attach]
完成以后，查找0，注意是单元格全匹配，查找全部后按CTRL+A键全选，然后删除行即可。

作者: supperboy 时间: 2010-11-10 18:51
在excel中我也知道转换,关键是我需要在Access做自动化

作者: pureshadow 时间: 2010-11-10 18:58
那我帮你转ACCESS版

作者: supperboy 时间: 2010-11-11 09:12
谢谢管理员,自己顶一下

作者: stony123456 时间: 2010-11-11 13:14
learning. very good.

作者: supperboy 时间: 2010-11-12 09:35
经过自己的努力,终于解决了,先把源代码贴上,给大家共享,与大家一起进步

Dim db2 As New ADODB.Connection
Dim rs2 As New ADODB.Recordset
Dim nSheetCount As Integer
Dim i As Integer
Dim AAA As Integer
Dim BBB As Integer

Dim sArrFieldsName

Sub 数据导入()

db2.ConnectionString = "

rovider=Microsoft.Jet.OLEDB.4.0

ersist Security Info=False;Data Source=" & CurrentProject.Path & "\test.mdb"
db2.Open

Dim NewXls As Excel.Application
Dim NewBook As Excel.Workbook
Dim NewSheet As Excel.Worksheet
'
Set NewXls = New Excel.Application '创建 EXCEL 应用程序，打开 EXCEL2000
Set NewBook = NewXls.Workbooks.Open(CurrentProject.Path & "\Demo.xls")  '创建工作簿
nSheetCount = NewBook.Worksheets.Count

sArrFieldsName = Array("尺码", "颜色", "数量")

Set rs2 = Nothing
rs2.CursorLocation = adUseClient
rs2.Open "select * from 1 ", db2, adOpenStatic, adLockPessimistic

Set NewSheet = NewBook.Worksheets(1)  '创建工作表

For AAA = 2 To 10 '尺码行数

      For BBB = 1 To 6  '颜色列数
         If NewSheet.Cells(AAA + 1, 1) <> "" Then
            If NewSheet.Cells(2, BBB + 1) <> "" Then
                  If Nz(NewSheet.Cells(AAA + 1, BBB + 1)) <> 0 Then
                     rs2.AddNew

                     rs2!尺码 = NewSheet.Cells(AAA + 1, 1).Value
                     rs2!颜色 = NewSheet.Cells(2, BBB + 1).Value
                     rs2!数量 = NewSheet.Cells(AAA + 1, BBB + 1).Value
                  End If
            End If
         End If
      Next
Next

rs2.Update

NewXls.Quit
db2.Close

End Sub

欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/)