Newsgroup: it.comp.appl.access
Titolo: R: Foglio di excel importato


nel copia e incolla è mancato un pezzo sorry
Ho un foglio di excel impostato tipo una queery a campi incrociati (righe
per colonne), dovrei importare questa query e creare una tabella con 3
campi:
Intestazione riga del foglio Excel
Intestazione colonna del foglio Excel
Valore incrociato delle due intestazioni
ES
Foglio excel :
        A        B        C
X     1         2          3
Y      4        5          6
dovrebbe diventare:
A     X        1
A     Y        4
B      X        2
B      Y        5
C      X        3
C      Y        6
Grato a chiunque possa aiutarmi
Massimo

 C   Y   6
Option Compare Database
Option Explicit
Option Base 0
Public Function XL2AC_xy( _
) As Boolean
  On Error GoTo erh
  Const c_sWbk$ = "C:\Progetti\mso\09\XL2AC.xy.xls"
  Const c_sRng$ = "TabellaValori"
  Const c_sTbl$ = "XL2AC xy"
  Const c_sFldSerie$ = "Serie"
  Const c_sFldAsse$ = "Asse"
  Const c_sFldValore$ = "Valore"
  Dim oXlApp      As Excel.Application
  Dim oXlWbk      As Excel.Workbook
  Dim oXlRngVals  As Excel.Range
  Dim oXlRngIRow  As Excel.Range
  Dim oXlRngICol  As Excel.Range
  Dim oXlRng      As Excel.Range
  Dim lRow        As Long
  Dim lCol        As Long
  Dim oAcApp        As Access.Application
  Dim oDaoDbs       As DAO.Database
  Dim oDaoRst       As DAO.Recordset
  Dim oDaoFldSerie  As DAO.Field
  Dim oDaoFldAsse   As DAO.Field
  Dim oDaoFldValore As DAO.Field
  Set oXlApp = New Excel.Application
  Set oXlWbk = oXlApp.Workbooks.Open(c_sWbk)
  Set oXlRngVals = oXlWbk.Names(c_sRng).RefersToRange
  Set oAcApp = Access.Application
  Set oDaoDbs = oAcApp.CurrentDb
  Set oDaoRst _
    = oDaoDbs.OpenRecordset( _
          c_sTbl _
        , DAO.dbOpenTable _
        , DAO.dbFailOnError)
  With oDaoRst.Fields
    Set oDaoFldSerie = .Item(c_sFldSerie)
    Set oDaoFldAsse = .Item(c_sFldAsse)
    Set oDaoFldValore = .Item(c_sFldValore)
  End With
  With oXlRngVals
    For lRow = 2 To .Rows.Count
      Set oXlRngIRow = .Cells(lRow, 1)
      For lCol = 2 To .Columns.Count
        Set oXlRngICol = .Cells(1, lCol)
        Set oXlRng = .Cells(lRow, lCol)
        With oXlRng
          Debug.Print _
              oXlRngICol.Value & ";" _
            ; oXlRngIRow.Value & ";" _
            ; .Value
          oDaoRst.AddNew
          oDaoFldSerie.Value = oXlRngICol.Value
          oDaoFldAsse.Value = oXlRngIRow.Value
          oDaoFldValore.Value = oXlRng.Value
          oDaoRst.Update
        End With
      Next
    Next
  End With
  XL2AC_xy = True
ext:
  On Error Resume Next
  oDaoRst.Close
  oXlApp.DisplayAlerts = False
  oXlApp.Quit
  Set oDaoFldValore = Nothing
  Set oDaoFldAsse = Nothing
  Set oDaoFldSerie = Nothing
  Set oDaoRst = Nothing
  Set oDaoDbs = Nothing
  Set oAcApp = Nothing
  Set oXlRng = Nothing
  Set oXlRngICol = Nothing
  Set oXlRngIRow = Nothing
  Set oXlRngVals = Nothing
  Set oXlWbk = Nothing
  Set oXlApp = Nothing
  Exit Function
erh:
  XL2AC_xy = False
  With Err
    MsgBox .Description, vbCritical, "ERR#" & CStr(.Number)
  End With
  Resume ext
End Function
    (Facci sapere se ed eventualmente come hai risolto. Grazie.)
--
Ciao :o)
Maurizio
--------
?SPQR(C)
 X
--------