i am using an access2000 database with excell office 2000 profesional. i am trying to read the database by item numbers to put the amount in a spreadsheet. i have it populating the spreeadsheet but it does it one amount at a time from left to right. what i need is the total of each item number to populate from top to bottom. below is the code i am using. i would appreciate any help or ideas on this.
Option Explicit
'rick
Public RowsCount As Integer
Public ColsCount As Integer
Public gColNameArr() As Variant
Public gRowNameArr() As Variant
Public gItemNumsArr() As Integer
Public gWhereStrArr() As String
Public fields As Collection
Public Sub Run()
Initialize
Import
End Sub
Public Sub Initialize()
Dim sht As Worksheet
Dim i As Integer
Dim j As Integer
Dim str As String
Dim where_str As String
ColsCount = 40
RowsCount = 80
ReDim gColNameArr(1 To ColsCount)
ReDim gRowNameArr(1 To RowsCount)
ReDim gItemNumsArr(1 To RowsCount, 1 To 7)
ReDim gWhereStrArr(1 To RowsCount)
'set columns array
Set sht = Worksheets("detail"
With sht
For i = 1 To 39
gColNameArr(i) = .Cells(5, i + 1)
Next i
For i = 1 To 80
gRowNameArr(i) = .Cells(i + 8, 1)
Next i
End With
Set sht = Nothing
Set sht = Worksheets("data"
With sht
For i = 1 To RowsCount
where_str = "WHERE ("
For j = 1 To 7
str = .Cells(i, j + 1)
If str = "" Then
gItemNumsArr(i, j) = 0
Else
gItemNumsArr(i, j) = CInt(str)
where_str = where_str & "EntryTable.[Item Number] = " & str & " OR "
End If
Next j
gWhereStrArr(i) = Left$(where_str, Len(where_str) - 4) & " "
Next i
End With
End Sub
Public Sub Import()
Dim sht As Worksheet
Dim sht1 As Worksheet
Dim conn_str As String
Dim sql_str As String
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim i As Integer
Dim j As Integer
Dim Amount As Double
Dim f As String
conn_str = "Provider=Microsoft.Jet.OLEDB.4.0.0; Data Source=C:\Documents and Settings\rhinson\My Documents\daily reports.mdb"
Set cn = New Connection
cn.Open conn_str
Set sht = Worksheets("Detail"
Set sht1 = Worksheets("Data"
For i = 1 To RowsCount
DoEvents
For j = 1 To ColsCount
DoEvents
Amount = 0
Set rs = New Recordset
If gWhereStrArr(i) <> "WHE) " Then
sql_str = "SELECT DISTINCT EntryTable.Amount as m " _
& "FROM (EntryTable INNER JOIN HeaderTable ON EntryTable.ID = HeaderTable.ID) " _
& "INNER JOIN ItemTable ON EntryTable.[Item number] = ItemTable.[Item Number] " _
& gWhereStrArr(i) _
& "AND (((ItemTable.Location)='" & gColNameArr(j) & "'))"
Else
sql_str = "SELECT DISTINCT EntryTable.Amount as m " _
& "FROM (EntryTable INNER JOIN HeaderTable ON EntryTable.ID = HeaderTable.ID) " _
& "INNER JOIN ItemTable ON EntryTable.[Item number] = ItemTable.[Item Number] " _
& "WHERE ItemTable.Location = '" & gColNameArr(j) & "'"
End If
rs.Open sql_str, cn, adOpenStatic, adLockReadOnly
Debug.Print sql_str
While Not rs.EOF
Amount = Amount + rs.fields("m"
rs.MoveNext
Wend
sht.Cells(i + 7, j + 1) = Amount
rs.Close
Set rs = Nothing
Next j
Next i
cn.Close
Set cn = Nothing
End Sub
Option Explicit
'rick
Public RowsCount As Integer
Public ColsCount As Integer
Public gColNameArr() As Variant
Public gRowNameArr() As Variant
Public gItemNumsArr() As Integer
Public gWhereStrArr() As String
Public fields As Collection
Public Sub Run()
Initialize
Import
End Sub
Public Sub Initialize()
Dim sht As Worksheet
Dim i As Integer
Dim j As Integer
Dim str As String
Dim where_str As String
ColsCount = 40
RowsCount = 80
ReDim gColNameArr(1 To ColsCount)
ReDim gRowNameArr(1 To RowsCount)
ReDim gItemNumsArr(1 To RowsCount, 1 To 7)
ReDim gWhereStrArr(1 To RowsCount)
'set columns array
Set sht = Worksheets("detail"
With sht
For i = 1 To 39
gColNameArr(i) = .Cells(5, i + 1)
Next i
For i = 1 To 80
gRowNameArr(i) = .Cells(i + 8, 1)
Next i
End With
Set sht = Nothing
Set sht = Worksheets("data"
With sht
For i = 1 To RowsCount
where_str = "WHERE ("
For j = 1 To 7
str = .Cells(i, j + 1)
If str = "" Then
gItemNumsArr(i, j) = 0
Else
gItemNumsArr(i, j) = CInt(str)
where_str = where_str & "EntryTable.[Item Number] = " & str & " OR "
End If
Next j
gWhereStrArr(i) = Left$(where_str, Len(where_str) - 4) & " "
Next i
End With
End Sub
Public Sub Import()
Dim sht As Worksheet
Dim sht1 As Worksheet
Dim conn_str As String
Dim sql_str As String
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim i As Integer
Dim j As Integer
Dim Amount As Double
Dim f As String
conn_str = "Provider=Microsoft.Jet.OLEDB.4.0.0; Data Source=C:\Documents and Settings\rhinson\My Documents\daily reports.mdb"
Set cn = New Connection
cn.Open conn_str
Set sht = Worksheets("Detail"
Set sht1 = Worksheets("Data"
For i = 1 To RowsCount
DoEvents
For j = 1 To ColsCount
DoEvents
Amount = 0
Set rs = New Recordset
If gWhereStrArr(i) <> "WHE) " Then
sql_str = "SELECT DISTINCT EntryTable.Amount as m " _
& "FROM (EntryTable INNER JOIN HeaderTable ON EntryTable.ID = HeaderTable.ID) " _
& "INNER JOIN ItemTable ON EntryTable.[Item number] = ItemTable.[Item Number] " _
& gWhereStrArr(i) _
& "AND (((ItemTable.Location)='" & gColNameArr(j) & "'))"
Else
sql_str = "SELECT DISTINCT EntryTable.Amount as m " _
& "FROM (EntryTable INNER JOIN HeaderTable ON EntryTable.ID = HeaderTable.ID) " _
& "INNER JOIN ItemTable ON EntryTable.[Item number] = ItemTable.[Item Number] " _
& "WHERE ItemTable.Location = '" & gColNameArr(j) & "'"
End If
rs.Open sql_str, cn, adOpenStatic, adLockReadOnly
Debug.Print sql_str
While Not rs.EOF
Amount = Amount + rs.fields("m"
rs.MoveNext
Wend
sht.Cells(i + 7, j + 1) = Amount
rs.Close
Set rs = Nothing
Next j
Next i
cn.Close
Set cn = Nothing
End Sub