Copying data from a MS Access form into Excel - ms-access

I have code that takes fields from a MS Access form and copies the data into a saved Excel file. The first record in Access in imported to Excel with a range of A2:I2. The second record in Access is imported to Excel with a range of A3:I3, and so on.... What currently happens now is if I close my form in Access and open it back up, and say I already had two records imported into this same Excel file, and now I want to add a third record, it will start over at the first row (A2:I2) and write over what is already there. My question is how can I, if I close and open Access keep it from starting over on (A2:I2), and instead start at the next available row, which to follow the example given would be (A4:I4)? This is the code I have
Private Sub Command73_Click()
Set objXLApp = CreateObject("Excel.Application")
Set objXLBook = objXLApp.Workbooks.Open("Y:\123files\Edmond\Hotel Reservation Daily.xls")
objXLApp.Application.Visible = True
With objXLBook.ActiveSheet
Set r = .usedRange
i = r.Rows.Count + 1
.Cells(i + 1, 1).Value = Me.GuestFirstName & " " & GuestLastName
.Cells(i + 1, 2).Value = Me.PhoneNumber
.Cells(i + 1, 3).Value = Me.cboCheckInDate
.Cells(i + 1, 4).Value = Me.cboCheckOutDate
.Cells(i + 1, 5).Value = Me.GuestNo
.Cells(i + 1, 6).Value = Me.RoomType
.Cells(i + 1, 7).Value = Me.RoomNumber
.Cells(i + 1, 8).Value = Date
.Cells(i + 1, 9).Value = Me.Employee
End With
Set r = Nothing
Set objXLBook = Nothing
Set objXLApp = Nothing
End Sub

You can get the last used row:
Set r = objXLBook.ActiveSheet.UsedRange
i = r.Rows.Count + 1
Some notes.
Private Sub Command73_Click()
''It is always a good idea to put sensible names on command buttons.
''It may not seem like much of a problem today, but it will get there
Dim objXLApp As Object
Dim objXLBook As Object
Dim r As Object
Dim i As Integer
''It is nearly always best to check whether Excel is open before
''opening another copy.
Set objXLApp = CreateObject("Excel.Application")
Set objXLBook = objXLApp.Workbooks.Open( _
"Y:\123files\Edmond\Hotel Reservation Daily.xls")
objXLApp.Application.Visible = True
''It is generally best to specify the sheet
''With objXLBook.ActiveSheet
With objXLBook.Sheets("Room Reservation")
''If the used range includes empty rows
''it may not suit
''Set r = .UsedRange
''i = r.Rows.Count + 1
''From comments, it appears that the data is dense
''but with a number of empty rows at the end of the sheet
i = .Range("A1").End(xlDown).Row + 1
.Cells(i, 1).Value = Me.GuestFirstName & " " & GuestLastName
.Cells(i, 2).Value = Me.PhoneNumber
.Cells(i, 3).Value = Me.cboCheckInDate
.Cells(i, 4).Value = Me.cboCheckOutDate
.Cells(i, 5).Value = Me.GuestNo
.Cells(i, 6).Value = Me.RoomType
.Cells(i, 7).Value = Me.RoomNumber
.Cells(i, 8).Value = Date
.Cells(i, 9).Value = Me.Employee
End With
''Tidy up
Set objXLBook = Nothing
Set objXLApp = Nothing
End Sub
You might also like to look at TransferSpreadsheet.
Another possibility is to use the RecordsetClone, for data from a form, or any recordset, for that matter. It does not give quite the same control, but it is very fast:
Dim objXLApp As Object
Dim objXLBook As Object
Dim r As Object
Dim i As Integer
Dim rs As DAO.Recordset
Set objXLApp = CreateObject("Excel.Application")
objXLApp.Visible = True
Set objXLBook = objXLApp.Workbooks.Open( _
"Y:\123files\Edmond\Hotel Reservation Daily.xls")
Set rs = Me.RecordsetClone
With objXLBook.Sheets("Sheet1")
Set r = .UsedRange
i = r.Rows.Count + 1
.Cells(i, 1).CopyFromRecordset rs
End With

Related

web scraping from google page no longer returns anything

The below Excel vba code use to work and return the market cap, 52 week low and current price into my spreadsheet. It no longer does though and cannot work out why. Class names haven't changed but the getElementsByClassName doesn't seem to return anything anymore I think.
Sub get_title_header()
Dim wb As Object
Dim doc As Object
Dim sURL As String
Dim i As Integer
Dim allElements As IHTMLElementCollection
Application.DisplayAlerts = False
Set wb = CreateObject("internetExplorer.Application")
sURL = "https://www.google.com/search?q=aapl+stock+quote"
wb.navigate sURL
wb.Visible = False
While wb.Busy
Application.Wait Now + #12:00:01 AM#
DoEvents
Wend
Set doc = wb.document.body
On Error GoTo err_clear
Set allElements = doc.getElementsByClassName("iyjjgb")
x = allElements(3).innerText
Sheet6.Cells(i + 1, 2).Value = x
x = allElements(8).innerText
Sheet6.Cells(i + 1, 3).Value = x
x = ""
x = allElements(0).innerText
Sheet6.Cells(i + 1, 4).Value = x
x = ""
err_clear:
If Err <> 0 Then
Err.Clear
Resume Next
End If
wb.Quit
End Sub

How can I move VBA-JSON output to specific cells in worksheet?

Very new to VBA. Trying to learn as much as I can. I can get the output that I want in the immediate window, but how can I move all of that to my worksheet?
I'm honestly not sure what to try or where to try it.
Option Explicit
Sub JsonMain()
Dim dict
Dim subDict
Dim strLine As String
' Read from file
Dim FilePath As String
FilePath = ThisWorkbook.Path + "\" + "Main.json"
Dim nFile As Integer
Dim strJson As String
nFile = FreeFile
Open FilePath For Input As #nFile
strJson = Input(LOF(nFile), nFile)
Close #nFile
Dim jp As Scripting.Dictionary
Set jp = JsonConverter.ParseJson(strJson)
Dim gameData As Scripting.Dictionary
Set gameData = jp("data")
Dim theseMonsters As Object
Set theseMonsters = gameData("monsters")
Debug.Print "there are " & theseMonsters.Count & " monsters in the profile"
Dim i As Long
Dim monster As Dictionary
Dim monsterName As Variant
Dim monsterDetails As Variant
For Each monsterName In theseMonsters.Keys
Debug.Print "Monster #" & monsterName
Set monsterDetails = theseMonsters(monsterName)
Debug.Print " -- name: " & monsterDetails("class_name")
Debug.Print " -- total level: " & monsterDetails("total_level")
Debug.Print " -- perfection: " & monsterDetails("perfect_rate")
Debug.Print " -- catch number: " & monsterDetails("create_index")
Dim battleStats As Collection
Set battleStats = monsterDetails("total_battle_stats")
Debug.Print " -- battle stats: ";
For i = 1 To battleStats.Count
Debug.Print battleStats.Item(i) & " ";
Next i
Debug.Print ""
' ...
Next monsterName
End Sub
Edit 1:
Expected results would be bold titles for each category that are printed in row A, with data going down in columns under those titles.
Here is an example output that I get in the immediate window:
Monster #47103
-- name: Monstratos
-- total level: 20
-- perfection: 53.763
-- catch number: 39
-- battle stats: 218 288 221 198 227 201
I would like Row A to contain these bold headers: Monster #, Name, Total Level, Perfection, Catch Number, HP, PA, PD, SA, SD, SPD (Battle Stats is not a header, but the individual battle stats are).
Below that, for this mon as an example, would be: 47103, Monstratos, 20, 53.763, 39, 218, 288, 221, 198, 227, 201.
I think you want something like the following. You incremement the row counter, r, each time you hit a new monster dictionary. For each item of interest within the monster dictionary the column increases by 1.
Option Explicit
Public Sub WriteOutBattleInfo()
Dim headers(), r As Long, i As Long, json As Object, key As Variant, ws As Worksheet, battleStats As Object
Set ws = ThisWorkbook.Worksheets("Sheet1")
headers = Array("Monster #", "Name", "Total Level", "Perfection", "Catch Number", "HP", "PA", "PD", "SA", "SD", "SPD")
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://www.etheremon.com/api/user/get_my_monster?trainer_address=0x2Fef65e4D69a38bf0dd074079f367CDF176eC0De", False
.send
Set json = JsonConverter.ParseJson(.responseText)("data")("monsters") 'dictionary of dictionaries
End With
r = 2
ws.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
For Each key In json.keys
With ws
.Cells(r, 1) = key
.Cells(r, 2) = json(key)("class_name")
.Cells(r, 3) = json(key)("total_level")
.Cells(r, 4) = json(key)("perfect_rate")
.Cells(r, 5) = json(key)("create_index")
Set battleStats = json(key)("total_battle_stats")
For i = 1 To battleStats.Count
.Cells(r, i + 5) = battleStats.item(i)
Next i
End With
r = r + 1
Next
End Sub

Split large CSV file with header into multiple CSV files for every nth row with a header

I have a large CSV file that I would like to split into multiple CSV files. I've tried numerous VBS scripts, but I cannot seem to get this.
This script does some of what I want but does not save them as CSV files:
Sub Split()
Dim rLastCell As Range
Dim rCells As Range
Dim strName As String
Dim lLoop As Long, lCopy As Long
Dim wbNew As Workbook
With ThisWorkbook.Sheets(1)
Set rLastCell = .Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious)
For lLoop = 1 To rLastCell.Row Step 35
lCopy = lCopy + 1
Set wbNew = Workbooks.Add
.Range(.Cells(lLoop, 1), .Cells(lLoop + 35, .Columns.Count)).EntireRow.Copy _
Destination:=wbNew.Sheets(1).Range("A1")
wbNew.Close SaveChanges:=True, Filename:="Inventory_" & lLoop + 34
Next lLoop
End With
End Sub
Added a saveas line to your code to specify the file format, you should be all set
Sub Split()
Dim rLastCell As range
Dim rCells As range
Dim strName As String
Dim lLoop As Long, lCopy As Long
Dim wbNew As Workbook
With ThisWorkbook.Sheets(1)
Set rLastCell = .Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious)
For lLoop = 2 To rLastCell.Row Step 35
lCopy = lCopy + 1
Set wbNew = Workbooks.Add
.Cells(1, 1).EntireRow.Copy _
Destination:=wbNew.Sheets(1).range("A1")
.range(.Cells(lLoop, 1), .Cells(lLoop + 35, .Columns.Count)).EntireRow.Copy _
Destination:=wbNew.Sheets(1).range("A2")
wbNew.SaveAs FileName:="Inventory_" & format(lLoop + 34,"0000") & ".csv", FileFormat:=xlCSV, Local:=True
wbNew.Close SaveChanges:=False
Next lLoop
End With
End Sub
Off the top of my head:
Const ForReading = 1
Const ForWriting = 2
Set fso = CreateObject("Scripting.FileSystemObject")
maxRows = 35
i = 0
n = 0
Set out = Nothing
Set csv = fso.OpenTextFile("C:\PATH\TO\your.csv", ForReading)
header = csv.ReadLine
Do Until csv.AtEndOfStream
If i = 0 Then
If Not out Is Nothing Then out.Close
Set out = fso.OpenTextFile("out_" & Right("00" & n, 2) & ".csv", ForWriting)
out.WriteLine(header)
n = n + 1
End If
out.WriteLine(csv.ReadLine)
i = (i + 1) Mod maxRows
Loop
csv.Close
If Not out Is Nothing Then out.Close

Insert data by batch?

I need a code where the user (after pasting data in a datasheet), when he clicks a button, the data will be inserted in a table (I was thinking of using an SQL statement here). In addition to that, one of the fields in that table will have to be calculated using the DCount function. So I need to calculate that per record. Let me know if the idea is not clear and I need to explain further. Also, if there are better ideas out there, do tell. Thanks!
Why not create some VBA to pull in the data from the spreadsheet, insert it into the table and then close down excel again. All in a button click
Take a look at the below for an example
Dim objApp As Excel.Application
Dim objBook As Excel.Workbook
Dim objSheet As Excel.Worksheet
Dim sSQL As String
Dim Path As String
Set db = CurrentDb()
Set objBook = Workbooks.Add(Template:=SheetLocation) 'Your excel spreadsheet file goes here where "SheetLocation is typed
Set objApp = objBook.Parent
Set objSheet = objBook.Worksheets("Sheet1") 'Name of sheet you want to View
objBook.Windows(1).Visible = True
objApp.Visible = True
objApp.DisplayAlerts = False
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
' connect to the Access database
Set cn = CurrentProject.Connection
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "INSERT YOUR TABLE NAME HERE", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
r = 2 ' the start row in the worksheet
Do While Len(Range("A" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("INSERT THE TABLE FIELD TO DUMP DATA IN HERE") = Range("A" & r).Value
.Fields("REPEAT AS ABOVE") = Range("B" & r).Value
.Fields("REPEAT AS ABOVE") = Range("C" & r).Value
.Fields("REPEAT AS ABOVE") = Range("D" & r).Value
.Fields("REPEAT AS ABOVE") = Range("E" & r).Value
.Fields("REPEAT AS ABOVE") = Range("F" & r).Value
.Fields("REPEAT AS ABOVE") = Range("G" & r).Value
.Fields("REPEAT AS ABOVE") = Range("H" & r).Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
objApp.Quit

ADO Execution - compile error: User-defined type not defined

I have the following ado connection from excel to access but it does not work, am getting the error above. Any ideas?
Sub ADO_to_access()
Dim database As New ADODB.Connection // ERROR HERE
Dim connectionstring As String
Dim NewSet As Recordset
Dim CurrentSheet As Worksheet
Set CurrentSheet = ActiveSheet
Set objaccess = Nothing
connectionstring = "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=C:\Users\Carlos\Desktop\VBA - CW - Database.mdb;"
database.Open connectionstring
' ************* MEN
Set NewSet = New ADODB.Recordset
NewSet.Open "Mens_Dept_Data", database, adOpenKeyset, adLockOptimistic, adCmdTable
x = 6
Do While Len(Range("P" & x).Formula) > 0
With NewSet
.AddNew
.Fields("Irina").Value = CurrentSheet.Range("P" & x).Value
.Fields("Thomas").Value = CurrentSheet.Range("Q" & x).Value
.Fields("Jackie").Value = CurrentSheet.Range("R" & x).Value
.Update
End With
x = x + 1
Loop
NewSet.Close
database.Close
End Sub
Did you reference the adodb library ? (From VBE, select Tools, References)
I belive that the problem might be in those types:
adOpenKeyset, adLockOptimistic, adCmdTable
Try to define them as follows:
var adOpenForwardOnly = 0, adOpenKeyset = 1, adOpenDynamic = 2, adOpenStatic = 3; //CursorType Values
var adLockReadOnly = 1, adLockPessimistic = 2, adLockOptimistic = 3, adLockBatchOptimistic = 4; //LockTypeEnum Values
var adStateClosed = 0, adStateOpen = 1, adStateConnecting = 2, adStateExecuting = 4; //ObjectStateEnum Values
var adUseServer = 2, adUseClient = 3 //CursorLocationEnum Values
var adCmdTable = 2 //CommandTypeEnum Values
After Edit:
Sorry this is for the JScrip dialect, but I am sure that you can chang it to VBScript. :)