About Us

Dave_C_C

I can but try...

I appreciate your response...

"Jim Thomlinson" wrote:

Is this do-able. Yes. That having been said it is a lot of work and not a
great project for a newbie. I can give you some code that writes to a
database, but you would have to know how to use it.

"Dave_C_C" wrote:

I'd like to start by saying I know nothing about VBA and have managed to
start with a script that was developed for me.

The script is below, what it does is traverse a spreadsheet that has weekly
columns and "flattens" out the data and writes it to a new tab so that I can
do pivot tables on it.

The data sets to flatten is so big now that that macro easily outstripes 65k
rows.

I'm stuck running the macro the exporting and importing the information by
hand into Access.

I would love to write directly to access the fields I need, but as soon as I
start with JET and ADO my eye glaze over. Again, forgive my newbieness.

The script writes to a tab, I'd love to get it to write to a database so
that I can have one stop shopping:

Private Sub cmdCancel_Click()
Unload Me
End
End Sub

Private Sub cmdOK_Click()
Dim FromRange As Range
Dim OurSheet As String
Dim NewSheet As String
Dim wksOld As Worksheet
Dim nextRow As Integer
Dim c As Range
Dim d As Range
Dim newC As Range
Dim nameRng As Range
Dim i As Integer
Dim nRows As Integer
Dim nLastRow As Integer
Dim nLastRow2 As Integer
Dim nNumOfDates As Integer
Dim nMoreThanOne As Integer
Dim nPage As Integer
Dim x As Integer

Application.ScreenUpdating = False

'No sheets selected, warn user, get out
If frmSheets.lstSheets.ListIndex = -1 Then
MsgBox "You must select at least one sheet"
Exit Sub
End If

On Error GoTo HandleError

'New sheet is sum of its parts plus suffix
nMoreThanOne = 0
NewSheet = ""
For x = 0 To frmSheets.lstSheets.ListCount - 1
If frmSheets.lstSheets.Selected(x) Then
nMoreThanOne = nMoreThanOne + 1
If nMoreThanOne = 1 Then
OurSheet = frmSheets.lstSheets.List(x)
nPage = ThisWorkbook.Sheets(OurSheet).Index
End If
NewSheet = NewSheet & frmSheets.lstSheets.List(x)
End If
Next x

NewSheet = NewSheet & "_FLAT"

'Delete if new sheet already exists
For Each wksNew In ThisWorkbook.Sheets
If wksNew.Name = NewSheet Then
wksNew.Delete
Exit For
End If
Next

OurSheet = ""
'Put the new sheet in
ThisWorkbook.Sheets.Add After:=Worksheets(nPage), Count:=1,
Type:=xlWorksheet
ActiveSheet.Name = NewSheet
Set wksNew = ThisWorkbook.Sheets(NewSheet)

'Get each sheet from the user, and keep getting it until it's right
nLastRow = 0
For x = 0 To frmSheets.lstSheets.ListCount - 1
If frmSheets.lstSheets.Selected(x) Then
OurSheet = frmSheets.lstSheets.List(x)
'nPage = ThisWorkbook.Sheets(OurSheet).Index

'Set the sheet we are currently working with
Set wksOld = ThisWorkbook.Sheets(OurSheet)

'Count number of rows
wksOld.Activate
ActiveCell.CurrentRegion.Select
nRows = ActiveCell.CurrentRegion.Rows.Count 'Turning out to be
1000 because of prepopulated "N/A" columns

wksNew.Activate
nNumOfDates = 36 'Number of dates across
'nLastRow = 0 - old, before listbox was added
For nextRow = 0 To nRows
'Copy from old sheet
Set c = wksOld.Range("A2:E2")
wksOld.Activate
Set FromRange = c.Offset(RowOffset:=nextRow)

'Let's not spin our wheels once we're out of rows
If FromRange.Cells(1).Value = "" And
FromRange.Cells(2).Value = "" And FromRange.Cells(3).Value = "" Then
Exit For
End If

'Copy to new sheet
wksNew.Activate
'Set newC = wksNew.Range("A2:E2")
Set newC = wksNew.Range("B2:F2")
Set nameRange = wksNew.Range("A2")
For i = nLastRow To (nLastRow + (nNumOfDates - 1))
newC.Offset(RowOffset:=i).Value = FromRange.Value
nameRange.Offset(RowOffset:=i).Value = OurSheet
Next i
nLastRow2 = nLastRow
nLastRow = nLastRow + nNumOfDates

'Copy percentages from old sheet
Set c = wksOld.Range("H2:W2")
wksOld.Activate
Set FromRange = c.Offset(RowOffset:=nextRow)

'Copy percentages to new sheet
'Set newC = wksNew.Range("G2")
Set newC = wksNew.Range("H2")
wksNew.Activate
For i = 0 To nNumOfDates
newC.Offset(RowOffset:=(nLastRow2 + i)).Value =
FromRange.Offset(ColumnOffset:=i).Value
Next i

'Copy dates from old sheet
Set FromRange = wksOld.Range("H1:W1")
wksOld.Activate
'Set newC = wksNew.Range("F2")
Set newC = wksNew.Range("G2")

'Copy dates to new sheet
wksNew.Activate
For i = 0 To nNumOfDates
newC.Offset(RowOffset:=(nLastRow2 + i)).Value =
FromRange.Offset(ColumnOffset:=i).Value
Next i

Next nextRow
End If
Next x 'Sheet

'kill objects
Set FromRange = Nothing
Set c = Nothing
Set d = Nothing
Set newC = Nothing
Set wksOld = Nothing
Set wksNew = Nothing

MsgBox ("Done!")

Application.ScreenUpdating = True

cmdCancel_Click
Exit Sub

HandleError:
MsgBox "There was a problem.", , "Business Objects Style Message"
cmdCancel_Click
End Sub

Private Sub UserForm_Activate()
Dim x As Integer
Dim wksList As Worksheet

'Load the sheets into the form listbox
For Each wksList In ThisWorkbook.Sheets
Me.lstSheets.AddItem wksList.Name
Next

'Show form
'Me.Show vbModal

Set wksList = Nothing

End Sub

Thread Tools	Search this Thread
Show Printable Version	Search this Thread: Advanced Search
Display Modes
Switch to Linear Mode Switch to Hybrid Mode Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Query from Access into Excel cause Access to go to read only	T Stephens	Excel Discussion (Misc queries)	0	March 24th 09 04:17 PM
Can Excel access data from Access?!	Al	Excel Discussion (Misc queries)	5	April 5th 08 03:52 PM
export access to excel. change access & update excel at same time	fastcar	Excel Discussion (Misc queries)	0	June 24th 05 09:27 PM
Access data -work in Excel- save in Access	s_u_resh	Excel Programming	1	October 25th 04 12:52 PM
Getting Access Error Messages when running Access through Excel	Dkline[_2_]	Excel Programming	0	October 12th 04 09:35 PM

Menu

About Us