Code:
Const NumRows As Integer = 1 ' Number Of Blank RowsConst TargetClm As String = "C"
Const TargetClm2 As String = "D" ' change to suit
Const TargetClm3 As String = "E" ' change to suit
Const TargetClm4 As String = "F" ' change to suit
Const TargetClm5 As String = "G" ' change to suit
Const TargetClm6 As String = "H" ' change to suit
Const TargetClm7 As String = "I" ' change to suit
Dim rs As DAO.Recordset
Dim xlAP As Object, xlWB As Object
Dim strPath As String, strFile As String, sSQL1 As String
Dim xlSHT1 As EXCEL.Worksheet, xlSHT2 As EXCEL.Worksheet, xlSHT3 As EXCEL.Worksheet, xlSHT4 As EXCEL.Worksheet, xlSHT5 As EXCEL.Worksheet, xlSHT6 As EXCEL.Worksheet
Dim xlSHT7 As EXCEL.Worksheet, xlSHT8 As EXCEL.Worksheet, xlSHT9 As EXCEL.Worksheet, xlSHT10 As EXCEL.Worksheet, xlSHT11 As EXCEL.Worksheet, xlAllSHTS As EXCEL.Worksheets
Dim iWHQty As Integer, iAllocated As Integer, iAvailable As Integer, intCount As Integer, intID As Integer, i As Integer, x As Integer, intLR As Integer
Dim r As Long ' Loop Counter
strPath = "C:\Users\davem\Desktop\"
strFile = "My File Name.xlsx"
Set xlAP = CreateObject("Excel.Application")
Set xlWB = xlAP.Workbooks.Open(strPath & strFile)
xlAP.Visible = True
Set xlSHT1 = xlWB.Worksheets(1)
'############### NOTE SORT NO IS SET AS NUMBER
sSQL1 = "SELECT tblStock.SortNo, tblStock.PONumber, tblStock.ItemType, tblStock.LiftNo, tblStock.StartQty, tblStock.AllocatedQty, tblStock.NewQty" _
& " FROM tblStock" _
& " WHERE (((tblStock.SortNo) < 99) And ((tblStock.ItemNo) Is Not Null))" _
& " ORDER BY tblStock.SortNo;"
Set rs = CurrentDb.OpenRecordset(sSQL1)
With xlSHT1
intCount = rs.RecordCount
xlSHT1.Cells(3, 3).CopyFromRecordset rs
For r = (.Cells(.Rows.Count, TargetClm).End(xlUp).Row - 1) To 2 Step -1
If .Cells(r, TargetClm).Value <> .Cells(r + 1, TargetClm).Value Then
.Cells(r + 1, TargetClm).Resize(NumRows).EntireRow.Insert
.Cells(r + 1, TargetClm).Interior.ColorIndex = 15
.Cells(r + 1, TargetClm2).Interior.ColorIndex = 15
.Cells(r + 1, TargetClm3).Interior.ColorIndex = 15
.Cells(r + 1, TargetClm4).Interior.ColorIndex = 15
.Cells(r + 1, TargetClm5).Interior.ColorIndex = 15
.Cells(r + 1, TargetClm6).Interior.ColorIndex = 15
.Cells(r + 1, TargetClm7).Interior.ColorIndex = 15
End If
Next r
' intID = 1
' Do While x < intCount
' x = x + 1
' If intID <> .Cells(3 + x, 1).Value Then
' .Cells(3 + x, 1).EntireRow.Insert
' intID = intID + 1
' intCount = intCount + 1
' x = x + 1
' End If
' Loop
intLR = xlSHT1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
.Range("J3:J" & intLR + 2).Interior.ColorIndex = 15
.Cells.EntireColumn.HorizontalAlignment = xlLeft
.Cells(intLR + 2, 3) = "TOTALS:"
.Cells(intLR + 2, 3).Interior.ColorIndex = 15
iWHQty = DSum("StartQty", "tblStock", "[LiftType] Is Not Null")
.Cells(intLR + 2, 7) = iWHQty
.Cells(intLR + 2, 7).Interior.ColorIndex = 15
iAllocated = DSum("AllocatedQty", "tblStock", "[LiftType] Is Not Null")
.Cells(intLR + 2, 8) = iAllocated
.Cells(intLR + 2, 8).Interior.ColorIndex = 15
iAvailable = DSum("NewQty", "tblStock", "[LiftType] Is Not Null")
.Cells(intLR + 2, 9) = iAvailable
.Cells(intLR + 2, 9).Interior.ColorIndex = 15
End With
Set xlAP = Nothing
Set xlWB = Nothing
Set xlSHT1 = Nothing
I am using a different database at home than work, i upload to work when i want to copy vb code
Add Blank Row After Group 2
Windows 10 
Access 2016
Reply With Quote
