Excel Access VBA

[Guest]

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

 

[Guest]

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.

 

[Guest]

I can but try...

I appreciate your response...

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.