自己已解决:交叉2DExcel表格如何导入到Access数据表中

supperboy

我有一张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

在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是对应的颜色。

完成以后，查找0，注意是单元格全匹配，查找全部后按CTRL+A键全选，然后删除行即可。

supperboy

在excel中我也知道转换,关键是我需要在Access做自动化

pureshadow

那我帮你转ACCESS版

supperboy

经过自己的努力,终于解决了,先把源代码贴上,给大家共享,与大家一起进步

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.0ersist 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

stony123456

learning. very good.

supperboy

谢谢管理员,自己顶一下