Looping through visible cells for excel to access insert - excel

I have a project I am working on where my team uses an excel front end to manipulate the data which in turn updates an access database back-end to hold the database. (there are good reasons for this)
The current version works by if a user changes data in a cell and wants to update the database they highlight the cell(s) and hit an update button. (this becomes annoying doing multiple updates). So I started playing with the worksheet_changed function.
In order for the worksheet_changed function to work the user has to move off of the 'updated' cell in order for excel to notice the change and update the code. (In my case hitting enter or down arrow after data entry). I have gotten this to work well using the offset property to look at the row above and enter that line into the database - however - when the spreadsheet is filtered as it always is...if the row above happens to be hidden it will update that row when actually I need the visible cell to update....so I am stuck - below is a small chunk of the code used to update the database.
Private Sub Worksheet_Change(ByVal Target As Range)
Refreshbuttons
Dim KeyCells As Range
Dim aCell As Range
Const TARGET_DB = "MKT DB1.accdb"
Dim VErrors(4) As String
VErrors(0) = "Y"
VErrors(1) = "YES"
VErrors(2) = "1"
VErrors(3) = "TRUE"
Dim NVErrors(5) As String
NVErrors(0) = "N"
NVErrors(1) = "NO"
NVErrors(2) = ""
NVErrors(3) = "0"
NVErrors(4) = "FALSE"
Set srch = Range("A4:Z4").Find("PROJECTID", , xlValues, xlWhole)
PRO = Chr(srch.Column + 64)
Set srch = Range("A4:Z4").Find("PROJECTDES", , xlValues, xlWhole)
PD = Chr(srch.Column + 64)
Set srch = Range("A4:Z4").Find("ECAT", , xlValues, xlWhole)
EC = Chr(srch.Column + 64)
Set srch = Range("A4:Z4").Find("SALEMODEL", , xlValues, xlWhole)
SM = Chr(srch.Column + 64)
Set srch = Range("A4:Z4").Find("MKDBROSOURCE", , xlValues, xlWhole)
MDR = Chr(srch.Column + 64)
Set srch = Range("A4:Z4").Find("SOLREVIEWED", , xlValues, xlWhole)
SRD = Chr(srch.Column + 64)
Set srch = Range("A4:Z4").Find("DBSUPPORTEDDUEDATE", , xlValues, xlWhole)
DSDD = Chr(srch.Column + 64)
Set srch = Range("A4:Z4").Find("CATEGORY", , xlValues, xlWhole)
CT = Chr(srch.Column + 64)
Set srch = Range("A4:Z4").Find("COMPLETE", , xlValues, xlWhole)
CMP = Chr(srch.Column + 64)
Set srch = Range("A4:Z4").Find("STYLECOUNT", , xlValues, xlWhole)
SC = Chr(srch.Column + 64)
Set srch = Range("A4:Z4").Find("ECATREADY", , xlValues, xlWhole)
ECR = Chr(srch.Column + 64)
Set srch = Range("A4:Z4").Find("ESTHRS", , xlValues, xlWhole)
EST = Chr(srch.Column + 64)
Set srch = Range("A4:Z4").Find("ACTUALHRS", , xlValues, xlWhole)
AH = Chr(srch.Column + 64)
Set cnn = New ADODB.Connection
MyConn = ThisWorkbook.Path & Application.PathSeparator & TARGET_DB
With cnn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Open MyConn
End With
projectCount = 0
**For Each C In Selection.Offset(-1,0).Rows
tmp = C.Address** // THIS IS WHERE MY ISSUE IS - IT LOOKS TO THE ROW ABOVE AND NOT THE VISIBLE ROW
ChangeFields = ""
ChangeValuesOld = ""
ChangeValuesNew = ""
If Range("A" & C.Row).EntireRow.Hidden = False Then
'create the recordset
Set rst = New ADODB.Recordset
rst.CursorLocation = adUseServer
'On Error GoTo Err1:
strSQL = "SELECT * FROM Projects WHERE Projectid = " & Range(PRO & C.Row).Value & ""
rst.Open Source:=strSQL, _
ActiveConnection:=cnn
If rst.EOF = False Then
'Start = GetTickCount()
If rst("Projectid") <> Range(PRO & C.Row).Value Or (IsNull(rst("Projectid")) And Range(PRO & C.Row).Value <> "") Then
If IsNull(rst("projectid")) Then
ChangeValuesOld = ChangeValuesOld & "NULL "
Else
ChangeValuesOld = ChangeValuesOld & rst("projectid") & " "
End If
If IsEmpty(Range(PRO & C.Row).Value) Then
ChangeValuesNew = ChangeValuesNew & "NULL "
Else
ChangeValuesNew = ChangeValuesNew & Range(PRO & C.Row).Value & " "
End If
ChangeFields = ChangeFields & "PROJECTID "
End If
If rst("ProjectDes") <> Range(PD & C.Row).Value Or (IsNull(rst("ProjectDes")) And Range(PD & C.Row).Value <> "") Then
If IsNull(rst("ProjectDes")) Then
ChangeValuesOld = ChangeValuesOld & "NULL "
Else
ChangeValuesOld = ChangeValuesOld & rst("ProjectDes") & " "
End If
If IsEmpty(Range(PD & C.Row).Value) Then
ChangeValuesNew = ChangeValuesNew & "NULL "
Else
ChangeValuesNew = ChangeValuesNew & Range(PD & C.Row).Value & " "
End If
ChangeFields = ChangeFields & "ProjectDes "
End If
If rst("ECAT") <> Range(EC & C.Row).Value Or (IsNull(rst("ECAT")) And Range(EC & C.Row).Value <> "") Then
If IsNull(rst("ECAT")) Then
ChangeValuesOld = ChangeValuesOld & "NULL "
Else
ChangeValuesOld = ChangeValuesOld & rst("ECAT") & " "
End If
If IsEmpty(Range(EC & C.Row).Value) Then
ChangeValuesNew = ChangeValuesNew & "NULL "
Else
ChangeValuesNew = ChangeValuesNew & Range(EC & C.Row).Value & " "
End If
ChangeFields = ChangeFields & "ECAT "
Any help is GREATLY appreciated - thank you

Target.address
this should reference the cell address of the changed cell, so unless you change a hidden cell a hidden cell should not be referenced
if you just need the row you should be able to do Target.Row

Related

Starting at a new row for every file opened, formatting every nth row

I'm looping through a folder and grabbing data points. The code below works, but I don't know how to get it to add the new data for each workbook below. It currently just pastes over each other. I tried to use i as an integer and count the number of folders and command to add 5 rows for each folder but my loop cancels out the next loop somehow. not to mention i don't know how to make it add for the next workbook. So I just need it to open the workbook, grab this data, close the workbook, open the next one, grab the same information and just put that right below what the previous workbook did.
My formatting simply needs to grab the copy range and copy the exact same range down to the last row.
Sub loopwb()
'Dim fc As Integer
'Dim sc As Range
fn = dir("C:\Users\user\Desktop\folder\*xlsx")
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Set wb = ThisWorkbook
Set ws = wb.Worksheets("List")
'Set sc = ws.Range("B11")
Do Until Len(fn) = 0
'Debug.Print fn
Set nwb = Workbooks.Open("C:\Users\user\Desktop\folder\" & fn)
Set nws = nwb.Worksheets("sht1")
ws.Range("B10").Value2 = "text"
ws.Range("B11").Value2 = nws.Range("A4").Value2
'change b11 to sc to initiate variable sequence
ws.Range("C11").Value2 = nws.Range("J6").Value2
ws.Range("H11").Value2 = nws.Range("P17").Value2
ws.Range("I11").Value2 = nws.Range("S17").Value2
ws.Range("K11").Value2 = nws.Range("S18").Value2
ws.Range("L11").Value2 = ", WAL"
ws.Range("M11").Value2 = nws.Range("L13").Value2
ws.Range("B12").Value2 = Chr(149) & " " & "text"
ws.Range("J11").Value2 = "text " & (nws.Range("E13").Value2 * 100) & " text:"
ws.Range("C12").Value2 = nws.Range("C16").Value2
ws.Range("H14").Value2 = Chr(149) & " " & "text:"
ws.Range("I14").Value2 = nws.Range("H36").Value2
ws.Range("B13").Value2 = Chr(149) & " " & "text:"
ws.Range("C13").Value2 = nws.Range("C20").Value2
ws.Range("B14").Value2 = Chr(149) & " " & "text:"
ws.Range("C14").Value2 = nws.Range("C14").Value2
ws.Range("H13").Value2 = Chr(149) & " " & "text:"
ws.Range("I13").Value2 = nws.Range("C17").Value2
If nws.Range("S10") = "text" Then
ws.Range("B15").Value2 = Chr(149) & " " & "text"
Else
ws.Range("B15").Value2 = Chr(149) & " " & "text"
End If
ws.Range("B16").Value2 = Chr(149) & " " & "text: " & nws.Range("S9").Value2
ws.Range("H16").Value2 = Chr(149) & " " & "text:"
ws.Range("I16").Value2 = nws.Range("S19").Value2
ws.Range("H15").Value2 = Chr(149) & " " & "text:"
ws.Range("I15").Value2 = nws.Range("H34").Value2
ws.Range("H12").Value2 = Chr(149) & " " & "text " & nws.Range("S11").Value2
nwb.Close savechanges:=False
fn = dir
Loop
Call format
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub format()
Dim cr As Range
Dim hr As Range
Dim lr As Long
Dim i As Integer
Set ws = ThisWorkbook.Worksheets("List")
With ws
Columns("B:M").EntireColumn.AutoFit
.Range("B11:M11").Font.Bold = True
.Range("B11:M11").Interior.Color = RGB(0, 48, 87)
.Range("B11:M11").Font.Color = RGB(255, 255, 255)
.Range("B16").Font.Bold = True
.Range("B15").Font.Bold = True
.Range("C12").NumberFormat = "#.000%"
.Range("C12").HorizontalAlignment = xlLeft
.Range("C16").Font.Bold = True
.Range("C16").HorizontalAlignment = xlLeft
.Range("K11").NumberFormat = "#.000%"
.Range("M11").NumberFormat = "General"
.Range("I14").NumberFormat = "#"
.Range("I14").HorizontalAlignment = xlLeft
.Range("I16").NumberFormat = "#.000%"
.Range("I15").NumberFormat = "$#,#"
.Range("I15").HorizontalAlignment = xlLeft
.Range("I13").HorizontalAlignment = xlLeft
.Range("I13").NumberFormat = "#0.000%"
Columns("D:E").ColumnWidth = 4
.Range("B10:M10").Font.Bold = True
.Range("B10:M10").Interior.Color = RGB(91, 160, 220)
.Range("B10:M10").Font.Color = RGB(255, 255, 255)
Set cr = .Range("B11:M16")
Set hr = .Range("B10:M10")
lr = .Range("B" & .Rows.count).End(xlUp).Row
'cr.Copy
' For i = 11 To lr Step 6
' PasteSpecial Paste:=xlPasteFormats
' Next i
End With
End Sub

Excel VBA Redshift Query Performance Improvements

I have an excel macro enabled workbook which offers the user the option of entering some parameters to use in the query as filter (WHERE) clauses. This in turn is supplied to the queries. I have about 3 queries which do not use the filters and 4 OR 5 depending on which filters are chosen that run using filters. The query complexity varies.
The queries are run against a Redshift Cluster. (All of the data is confidential and the RS is internal connection only, so I can't give the entire query or anything, just examples)
The 3 small queries are 1-2 lines.
3 or 4 of the remaining 5 are about 40 lines
5th is about 100.
When run directly on the cluster with no filters: returns ~42400 rows and 23 Columns
3 small queries run and load to the excel file in less than 3 seconds or so each
Medium query 1: On Cluster - ~1 Seconds
Medium Query 2: On Cluster ~5 Seconds
Medium Query 3: On Cluster - ~9 Seconds
Large Query 1: On Cluster - ~24 seconds
Now here in lies the issue, when I run these queries in vba using the following for each query to update a listboject (example code) it takes 980.59 (~16.4 Minutes) Seconds
CS = "ODBC;Driver={Amazon Redshift (x64)};SERVER={RS1.us-east-1.redshift.amazonaws.com};PORT=8192;DATABASE=db1;UID=user;PASSWORD=fakepasswrod;sslmode=require"
With Sheet2.ListObjects.Add(SourceType:=0, Source:=CS, Destination:=Sheet2.Range("$A$1")).QueryTable
.CommandText = Sql
.RefreshStyle = xlInsertDeleteCells
.AdjustColumnWidth = True
.ListObject.DisplayName = "Name_of_LO_1"
.Refresh BackgroundQuery:=False
End With
In addiiton, I have to give the users the ability to do Wildcards, Comma Separated Lists, and single entries to filters. That part doesn't take long to build from the cell values.
I have to build the filters with large if statements similar to the one as follows
'Filter Fields
C_List = UCase(ThisWorkbook.Sheets(Sheet1.Name).Range("D1").Value)
S_List = UCase(ThisWorkbook.Sheets(Sheet1.Name).Range("D2").Value)
F_List = UCase(ThisWorkbook.Sheets(Sheet1.Name).Range("D3").Value)
s_year = ThisWorkbook.Sheets(Sheet1.Name).Range("D4").Value
Scen = "'" & ThisWorkbook.Sheets(Sheet1.Name).Range("D5").Value & "'"
prior_s_year_1 = "'" & ThisWorkbook.Sheets(Sheet1.Name).Range("D6").Value & "'"
prior_Scen_1 = "'" & ThisWorkbook.Sheets(Sheet1.Name).Range("D7").Value & "'"
prior_s_year_2 = "'" & ThisWorkbook.Sheets(Sheet1.Name).Range("D8").Value & "'"
prior_Scen_2 = "'" & ThisWorkbook.Sheets(Sheet1.Name).Range("D9").Value & "'"
cat = UCase(ThisWorkbook.Sheets(Sheet1.Name).Range("D10").Value)
subcat = UCase(ThisWorkbook.Sheets(Sheet1.Name).Range("D11").Value)
If Site_List = "" And Cluster_List = "" And FBN_List = "" Then
response = MsgBox("You have chosen no Site, Cluster or FBN filters, this will pull all data and may take some time" & vbNewLine & "Do you wish to continue?", vbYesNo)
If response = vbNo Then
Call MsgBox("Exiting data retrieval, please enter Site, Cluster or FBN filters and restart", vbOKOnly)
Call DeleteConnections
Exit Sub
End If
ElseIf C_List = "ALL" Then
UserDefinedFilters = " bd.reg IN ( SELECT DISTINCT c FROM att_1 ) "
ElseIf S_List <> "" And C_List <> "" And F_List <> "" Then
S_List = Replace(S_List, ", ", ",")
C_List = Replace(C_List, ", ", ",")
F_List = Replace(F_List, ", ", ",")
UserDefinedFilters = UserDefinedFilters & " UPPER(s) in ('" & Replace(S_List, ",", "','") & "')" & _
vbNewLine & " AND UPPER(reg) in ('" & Replace(C_List, ",", "','") & "')" & _
vbNewLine & " AND UPPER(f) in ('" & Replace(F_List, ",", "','") & "')"
ElseIf S_List <> "" And C_List <> "" And F_List = "" Then
S_List = Replace(S_List, ", ", ",")
Cluster_List = Replace(C_List, ", ", ",")
UserDefinedFilters = UserDefinedFilters & " UPPER(s) in ('" & Replace(S_List, ",", "','") & "')" & _
vbNewLine & " AND UPPER(reg) in ('" & Replace(C_List, ",", "','") & "')"
ElseIf S_List <> "" And C_List = "" And F_List = "" Then
S_List = Replace(S_List, ", ", ",")
UserDefinedFilters = UserDefinedFilters & " UPPER(s) in ('" & Replace(S_List, ",", "','") & "')"
ElseIf S_List = "" And C_List <> "" And F_List = "" Then
C_List = Replace(C_List, ", ", ",")
UserDefinedFilters = UserDefinedFilters & " UPPER(reg) in ('" & Replace(C_List, ",", "','") & "')"
ElseIf S_List = "" And C_List = "" And F_List <> "" Then
If InStr(1, F_List, ",") > 0 Then
F_List = Replace(F_List, ", ", ",")
UserDefinedFilters = UserDefinedFilters & " UPPER(bd.f) in ('" & Replace(UCase(F_List), ",", "','") & "')"
ElseIf InStr(1, F_List, "*") > 0 Then
UserDefinedFilters = UserDefinedFilters & " UPPER(bd.f) LIKE '%" & Replace(UCase(F_List), "*", "") & "%'"
ElseIf InStr(1, F_List, "ABC") > 0 Then
UserDefinedFilters = UserDefinedFilters & " UPPER(bd.f) LIKE '%" & UCase(Left(F_List, 12)) & "%'"
Else
UserDefinedFilters = UserDefinedFilters & " UPPER(bd.f) in ('" & UCase(F_List) & "')"
End If
ElseIf S_List = "" And C_List <> "" And F_List <> "" Then
If InStr(1, F_List, ",") > 0 Then
F_List = Replace(F_List, ", ", ",")
UserDefinedFilters = UserDefinedFilters & " UPPER(bd.f) in ('" & Replace(UCase(F_List), ",", "','") & "')"
ElseIf InStr(1, F_List, "*") > 0 Then
UserDefinedFilters = UserDefinedFilters & " UPPER(bd.f) LIKE '%" & Replace(UCase(F_List), "*", "") & "%'"
Else
UserDefinedFilters = UserDefinedFilters & " UPPER(bd.f) in ('" & UCase(F_List) & "')"
End If
End If
'Cat and SubCat Filters
If cat <> "" And subcat <> "" Then
cat = Replace(cat, ",", "','")
subcat = Replace(subcat, ",", "','")
BCSFilters = BCSFilters & " AND UPPER(sca.cat) IN ('" & cat & "')" & _
vbNewLine & "AND UPPER(sca.subcat) in ('" & subcat & "')"
ElseIf cat <> "" And subcat = "" Then
cat = Replace(cat, ",", "','")
BCSFilters = BCSFilters & " AND UPPER(sca.cat) IN ('" & cat & "')"
ElseIf cat = "" And subcat <> "" Then
subcat = Replace(subcat, ",", "','")
BCSFilters = BCSFilters & " AND UPPER(sca.subcat) IN ('" & subcat & "')"
End If
The above is only two sets, but it should give you the idea of what I am having to do for building the where clause.
I cannot find a way to get recordsets working using ADODB and I am not sure if that would be faster or not. I need to do this DSNless if at all possible because the file is used across a wide swath of users. Anything that anyone can think of that might help reduce this huge time in the queries?
EDIT:
Adding the code I attempted for records sets:
Dim conn As Object
Dim rs As Object
Set conn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
CS = "Driver={Amazon Redshift (x64)};DATA SOURCE={RS1.us-east-1.redshift.amazonaws.com};PORT=8192;DATABASE=db1;UID=user;PWD=fakepasswrod;sslmode=require"
conn.Open CS
Set RegAtt = ThisWorkbook.Sheets(Sheet6.Name)
RegAtt.Cells.Clear
RegSql = "SELECT cl,reg,curr FROM schema.table1"
rs.Open RegSql
With RegAtt.ListObjects.Add(xlSrcQuery, rs, Destination:=RegAtt.Range("$A$1")).QueryTable
'.CommandText = RegSql
.RefreshStyle = xlInsertDeleteCells
.AdjustColumnWidth = True
.ListObject.DisplayName = "LO_2"
.Refresh BackgroundQuery:=False
End With
That connection string I get a driver not found error.
This CS = "Driver={Amazon Redshift (x64)};SERVER={RS1.us-east-1.redshift.amazonaws.com};PORT=8192;DATABASE=db1;ID=user;PASSWORD=fakepasswrod;sslmode=require"
I get 3709 - The connection cannot be used to perform this operation. It is either closed or invalid in this context.
This won't change the performance but you may find benefit in adopting a more object-orientated approach to building the queries. For example if you define a class module to hold the parameters and logic, then the build script becomes something like this ;
Sub BuildFilters()
Dim wb As Workbook, ws As Worksheet, response
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
Const msg1 = "You have chosen no Site, Cluster or FBN filters," & _
"this will pull all data and may take some time" & vbNewLine & _
"Do you wish to continue?"
Const msg2 = "Exiting data retrieval, please enter Site, Cluster or FBN filters and restart"
Dim Qb As New QueryBuilder
Qb.Init ws ' get parameters
If Qb.hasNone Then
response = MsgBox(msg1, vbYesNo)
If response = vbNo Then
Call MsgBox(msg2, vbOKOnly)
'Call DeleteConnections
End If
Else
' build SQL
Qb.BuildUDFilter
Qb.BuildBCSFilters
' dump to sheet to check result
ws.Range("D13") = Qb.UDFilter
ws.Range("D15") = Qb.BCSFilters
End If
End Sub
Class Module QueryBuilder
Option Explicit
Public BCSFilters As String
Public UDFilter As String
Dim C_List As String, hasC As Boolean
Dim S_List As String, hasS As Boolean
Dim F_List As String, hasF As Boolean
Dim s_year As String
Dim Scen As String
Dim prior_s_year_1 As String
Dim prior_Scen_1 As String
Dim prior_s_year_2 As String
Dim prior_Scen_2 As String
Dim cat As String, hasCat As Boolean
Dim subcat As String, hasSubcat As Boolean
Dim count As Integer, hasAny As Boolean
' Initialise Object from Sheet
Sub Init(ws As Worksheet)
With ws
C_List = .Cells(1, 4) ' D1
S_List = .Cells(2, 4)
F_List = .Cells(3, 4)
s_year = Cells(4, 4)
Scen = quoted(.Cells(5, 4))
prior_s_year_1 = quoted(.Cells(6, 4))
prior_Scen_1 = quoted(.Cells(7, 4))
prior_s_year_2 = quoted(.Cells(8, 4))
prior_Scen_2 = quoted(.Cells(9, 4))
cat = .Cells(10, 4)
subcat = .Cells(11, 4)
End With
hasC = CBool(Len(C_List))
hasS = CBool(Len(S_List))
hasF = CBool(Len(F_List))
hasCat = CBool(Len(cat))
hasSubcat = CBool(Len(subcat))
End Sub
Function hasNone() As Boolean
hasNone = Not (hasC Or hasS Or hasF)
End Function
Sub BuildUDFilter()
Dim sql As String
count = 0
If UCase(C_List) = "ALL" Then
sql = " bd.reg IN ( SELECT DISTINCT c FROM att_1 )"
Else
If hasC Then sql = BuildSelect("reg", C_List)
If hasS Then sql = sql & BuildSelect("s", S_List)
If hasF Then sql = sql & BuildSelect("f", F_List)
End If
UDFilter = sql
End Sub
Sub BuildBCSFilters()
Dim sql As String
count = 0
If hasCat Then sql = BuildSelect("sca.cat", cat)
If hasSubcat Then sql = sql & BuildSelect("sca.subcat", subcat)
BCSFilters = sql
End Sub
Private Function BuildSelect(v As String, s As String)
Dim ar As Variant, i As Integer, sql As String
s = UCase(s)
If CBool(InStr(s, "*")) Then
s = Replace(s, "*", "")
sql = " LIKE '%" & s & "%'"
ElseIf CBool(InStr(1, s, "ABC")) Then
s = Left(s, 12)
sql = " LIKE '%" & s & "%'"
Else
ar = Split(s, ",")
For i = 0 To UBound(ar)
ar(i) = Trim(ar(i))
Next
If UBound(ar) = 0 Then
sql = " = '" & ar(0) & "'"
Else
sql = " IN ('" & Join(ar, "','") & "')"
End If
End If
sql = " UPPER(" & v & ")" & sql
If count > 0 Then
sql = vbNewLine & "AND" & sql
End If
count = count + 1
BuildSelect = sql
End Function
Private Function quoted(s) As String
quoted = "'" & s & "'"
End Function
It could be that the line .AdjustColumnWidth = True is contributing to the performance drop? (as it has to load the data to determine auto widths).
Have you considered performing the majority of the code with Application.ScreenUpdating set to False and Application.Calculation set to xlCalculationManual?
For details, see https://www.microsoft.com/en-us/microsoft-365/blog/2009/03/12/excel-vba-performance-coding-best-practices/
This may be worth a try to see if it improves performance. If it does:
You could them put some appropriate user display messages in places for the duration of time that the screen updating is disabled.
Good practice is to store and then restore values for ScreenUpdating and Calculation, so that the environment is left as it was found at the beginning of your subroutine

Print function selecting wrong Type of Change option excel vba

I have code below for a print function created in VBA. When I select "Return from leave" under the drop down "Type of Change", my print macro prints as a "salary" change type, not "return from leave". I cant see where I went wrong in my code or what is causing the issue... Any thoughts? Thanks in advance!
Sub pcf_print()
Dim ws As Worksheet
Dim datasheet As Worksheet
Dim fs As Object
Dim str As String
Dim bool As Boolean
If Len(ActiveSheet.Name) < 3 Then
MsgBox "This worksheet is not a PCF"
Exit Sub
End If
If Left(ActiveSheet.Name, 3) <> "PCF" Then
MsgBox "This worksheet is not a PCF"
Exit Sub
End If
'MsgBox Right(ActiveSheet.Name, Len(ActiveSheet.Name) - 1 - InStr(ActiveSheet.Name, " v")) 'Right(ActiveSheet.Name, 4)
If InStr(ActiveSheet.Name, " vv") Then
If (CDbl(Right(ActiveSheet.Name, Len(ActiveSheet.Name) - 1 - InStr(ActiveSheet.Name, " vv") - 1)) >= 1.2 And (ActiveSheet.Range("F10") = "(select)" Or ActiveSheet.Range("F10") = "" Or ActiveSheet.Range("F10") = "(sélect.)")) Then
MsgBox "This form has not been completed"
Exit Sub
End If
Else
If (CDbl(Right(ActiveSheet.Name, Len(ActiveSheet.Name) - 1 - InStr(ActiveSheet.Name, " v"))) < 1.2 And (ActiveSheet.Range("F9") = "(select)" Or ActiveSheet.Range("F9") = "")) Or (CDbl(Right(ActiveSheet.Name, Len(ActiveSheet.Name) - 1 - InStr(ActiveSheet.Name, " v"))) >= 1.2 And (ActiveSheet.Range("F10") = "(select)" Or ActiveSheet.Range("F10") = "" Or ActiveSheet.Range("F10") = "(sélect.)")) Then
MsgBox "This form has not been completed"
Exit Sub
End If
End If
Set datasheet = ActiveSheet
If ActiveWorkbook.Worksheets("Form Lists").Range("CorpOrStore") = "Corp" Then
str = "Corporate"
Else
str = "Stores"
End If
Set fs = CreateObject("Scripting.FileSystemObject")
bool = fs.FolderExists("H:\HR\Online PCF Archive\" & str & "\" & Trim(datasheet.Range("StoreDeptResult")) & "\")
If Not bool Then
MkDir "H:\HR\Online PCF Archive\" & str & "\" & Trim(datasheet.Range("StoreDeptResult")) & "\"
End If
If InStr(ActiveSheet.Name, " vv") Then
If CDbl(Right(ActiveSheet.Name, Len(ActiveSheet.Name) - 1 - InStr(ActiveSheet.Name, " vv") - 1)) >= 1.2 Then
ActiveWorkbook.SaveAs "H:\HR\Online PCF Archive\" & str & "\" & Trim(datasheet.Range("StoreDeptResult")) & "\" & Replace(datasheet.Range("F10"), "/", "_") & " for " & datasheet.Range("J17") & ", " & datasheet.Range("F17") & " effective " & Month(datasheet.Range("F12")) & "-" & Day(datasheet.Range("F12")) & "-" & Year(datasheet.Range("F12")) & ".xls"
End If
Else
If CDbl(Right(ActiveSheet.Name, Len(ActiveSheet.Name) - 1 - InStr(ActiveSheet.Name, " v"))) >= 1.2 Then
ActiveWorkbook.SaveAs "H:\HR\Online PCF Archive\" & str & "\" & Trim(datasheet.Range("StoreDeptResult")) & "\" & Replace(datasheet.Range("F10"), "/", "_") & " for " & datasheet.Range("J17") & ", " & datasheet.Range("F17") & " effective " & Month(datasheet.Range("F12")) & "-" & Day(datasheet.Range("F12")) & "-" & Year(datasheet.Range("F12")) & ".xls"
Else
ActiveWorkbook.SaveAs "H:\HR\Online PCF Archive\" & str & "\" & Trim(datasheet.Range("StoreDeptResult")) & "\" & datasheet.Range("F9") & " for " & datasheet.Range("J16") & ", " & datasheet.Range("F16") & " effective " & Month(datasheet.Range("F11")) & "-" & Day(datasheet.Range("F11")) & "-" & Year(datasheet.Range("F11")) & ".xls"
End If
End If
Set ws = ActiveWorkbook.Worksheets("Payroll Forms")
If Right(ActiveSheet.Name, 5) = "v1.20" Then
ActiveWorkbook.Worksheets("Form Lists").Unprotect "0nl1n3"
ActiveWorkbook.Worksheets("Form Lists").Range("B8") = "A1:G76"
ActiveWorkbook.Worksheets("Form Lists").Range("B9") = "A80:G157"
ActiveWorkbook.Worksheets("Form Lists").Range("B10") = "A160:G225"
ActiveWorkbook.Worksheets("Form Lists").Range("B11") = "A228:G259"
ActiveWorkbook.Worksheets("Form Lists").Range("B12") = "A228:G259"
ActiveWorkbook.Worksheets("Form Lists").Range("B13") = "A228:G259"
ActiveWorkbook.Worksheets("Form Lists").Range("B14") = "A263:G338"
ActiveWorkbook.Worksheets("Form Lists").Range("B15") = "A263:G338"
ActiveWorkbook.Worksheets("Form Lists").Range("B16") = "A343:G367"
ActiveWorkbook.Worksheets("Form Lists").Range("B17") = "A263:G338"
ActiveWorkbook.Worksheets("Form Lists").Range("B18") = "A160:G225"
ActiveWorkbook.Worksheets("Form Lists").Range("B19") = "A370:G420"
ActiveWorkbook.Worksheets("Form Lists").Protect "0nl1n3"
End If
If Right(ActiveSheet.Name, 5) = "v1.20" Or Right(ActiveSheet.Name, 5) = "v1.21" Or str = "Corporate" Then
ws.PageSetup.PrintArea = ActiveWorkbook.Worksheets("Form Lists").Range("H2")
Else
ws.PageSetup.PrintArea = ActiveWorkbook.Worksheets("Form Lists").Range("i2")
End If
ActiveWorkbook.Unprotect "0nl1n3"
ws.Visible = xlSheetVisible
ws.PrintOut
ws.Visible = xlSheetHidden
ActiveWorkbook.Protect "0nl1n3"
ActiveWorkbook.Close False
End Sub
OP says:
When I select "Return from leave" under the drop down "Type of Change", my print macro prints as a "salary" change type, not "return from leave"
Assuming that the
"salary" change type
corresponds to the "default print" i.e.:
ws.PageSetup.PrintArea = ActiveWorkbook.Worksheets("Form Lists").Range("i2")
It seems that the reason the code provided always prints the default range, it's because the lines that determine the printed output are validating the ActiveSheet.Name instead of the value in the "Type of Change field and print"
Solution proposed:
Change these lines to reflect the cell where the "Type of Change field and print" is located:
Replace ActiveSheet.Name with the corresponding cell.address i.e.: F10 and update as required the comparisons against "v1.20" and "v1.21"
If Right(ActiveSheet.Name, 5) = "v1.20" _
Or Right(ActiveSheet.Name, 5) = "v1.21" _
Or str = "Corporate" Then
ws.PageSetup.PrintArea = ActiveWorkbook.Worksheets("Form Lists").Range("H2")
Else
ws.PageSetup.PrintArea = ActiveWorkbook.Worksheets("Form Lists").Range("i2")
End If
It should become (comparison values shown as a reference, they should be updated in line with the choices in the drop-down list) :
If ActiveSheet.Range("F10").Value2 = "Return from leave" _
Or str = "Corporate" Then
ws.PageSetup.PrintArea = ActiveWorkbook.Worksheets("Form Lists").Range("H2")
Else
ws.PageSetup.PrintArea = ActiveWorkbook.Worksheets("Form Lists").Range("i2")
End If
Note:
1. Avoid using ActiveWorkbook and ActiveSheet, suggest to replace all instances of them by: ThisWorkbook and datasheet respectively.
2. Additionally, I would suggest to review and incorporate the use of With statement and Select Case statement throughout your procedure.

How do I update a MS Access database using excel power query?

I have a quick question. So I stored all the database in access (which is local) and then I use excel's power query to import the data from access. But I want whatever changes made in excel spreadsheet (That I imported information from access) to be made in access directly using power query? Is there any way?
Thanks in advance!
I don't think this is a good idea, but you could try something like this concept.
Sub ImportFromAccess()
Dim conn As ADODB.Connection
Dim myRecordset As ADODB.Recordset
Dim strConn As String
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & "C:\your_path_here\Northwind.mdb"
Set myRecordset = New ADODB.Recordset
FocusRow = ActiveCell.Row
With myRecordset
.Open "SELECT * FROM PersonInformation WHERE ID=" & Worksheets("Sheet1").Range("A2").Value, _
strConn, adOpenKeyset, adLockOptimistic
' This assumes that ID is a number field. If it is a text field, use
' .Open "SELECT * FROM PersonInformation WHERE ID='" & Worksheets("Sheet1").Range("A2").Value & "'", _
strConn, adOpenKeyset, adLockOptimistic
.Fields("ID").Value = Worksheets("Sheet1").Range("A" & FocusRow).Value
.Fields("FName").Value = Worksheets("Sheet1").Range("B" & FocusRow).Value
.Fields("LName").Value = Worksheets("Sheet1").Range("C" & FocusRow).Value
.Fields("Address").Value = Worksheets("Sheet1").Range("D" & FocusRow).Value
.Fields("Age").Value = Worksheets("Sheet1").Range("E" & FocusRow).Value
.Update
.Close
End With
Set myRecordset = Nothing
Set conn = Nothing
End Sub
AND
Sub UpdateRecordsInAccess()
Dim rng As Range
Dim r As Long
Dim conn As ADODB.Connection
Dim strConn As String
Dim strSQL As String
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _
"C:\your_path_here\Northwind.mdb"
Set conn = New ADODB.Connection
conn.Open strConn
With Worksheets("Sheet1")
lastrow = .Range("A2").End(xlDown).Row
lastcolumn = .Range("A2").End(xlToRight).Column
Set rng = .Range(.Cells(lastrow, 1), .Cells(lastrow, lastcolumn))
End With
'therow = 1
For i = 2 To lastrow
'r = rng.Row
'If r > 1 Then
strSQL = "UPDATE PersonInformation SET " & _
"FName='" & Worksheets("Sheet1").Range("B" & i).Value & "', " & _
"LName='" & Worksheets("Sheet1").Range("C" & i).Value & "', " & _
"Address='" & Worksheets("Sheet1").Range("D" & i).Value & "', " & _
"Age=" & Worksheets("Sheet1").Range("E" & i).Value & " WHERE " & _
"ID=" & Worksheets("Sheet1").Range("A" & i).Value
conn.Execute strSQL
'End If
'r = r + 1
Next i
conn.Close
Set conn = Nothing
End Sub
Sub UpdateRecordsInAccess()
Dim rng As Range
'Dim r As Long
Dim conn As ADODB.Connection
Dim strConn As String
Dim strSQL As String
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Users\username\Desktop\DatabaseResplann.mdb;"
Set conn = New ADODB.Connection
conn.Open strConn
With Worksheets("Sheet1")
lastrow = .Range("A2").End(xlDown).Row
lastcolumn = .Range("A2").End(xlToRight).Column
Set rng = .Range(.Cells(lastrow, 1), .Cells(lastrow, lastcolumn))
End With
'therow = 1
For i = 2 To lastrow
'r = rng.Row
'If r > 1 Then
strSQL = "UPDATE Allocation SET " & _
"Resource Name='" & Worksheets("Sheet1").Range("B" & i).Value & "', " & _
"Child PID='" & Worksheets("Sheet1").Range("C" & i).Value & "', " & _
"Fct wk#='" & Worksheets("Sheet1").Range("D" & i).Value & "', " & _
"Fct Hrs='" & Worksheets("Sheet1").Range("E" & i).Value & "', " & _
"Fct %='" & Worksheets("Sheet1").Range("F" & i).Value & "', " & _
"Comment='" & Worksheets("Sheet1").Range("G" & i).Value & " WHERE " & _
"Resource ID='" & Worksheets("Sheet1").Range("A" & i).Value
conn.Execute strSQL
'End If
'r = r + 1
Next i
conn.Close
Set conn = Nothing
End Sub

Run-time error 5 in excel while saving a word document as a pdf

So I've been running this code on a couple computers for awhile. However, the spreadsheet has begun to crash and refuses to save, so I created a new one, with everything the same. It crashes as I try and save my word document as a PDF, specifically, this line
wrdDoc.ExportAsFixedFormat OutputFileName:=Path & "Lot " & Lot_Number & " " & Address & " " & Suburb & " " & Job & " - s40" & ".pdf", _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
Here is my full code, My apologies for lack of comments etc, it was written to be used only by me.
Sub AutoFill()
ScreenUpdating = False
Dim Job As String
Dim Rail As String
Dim Panel_Type As String
Dim Address As String
Dim Lot_Number As Integer
Dim Suburb As String
Dim Town As String
Dim Town_Check As String
Dim Current_Date As String
Dim DTC As String
Dim WordFileName As String
Dim Path As String
Dim i As Integer
Dim wrdApp As Object
Dim wrdDoc As Object
Dim count As Integer
count = Range("Solarcount")
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
wrdApp.DisplayAlerts = wdAlertsNone
For i = 1 To count
Job = Range("WordArray").Cells(i, 1)
Rail = Range("WordArray").Cells(i, 2)
Panel_Type = Range("WordArray").Cells(i, 3)
Lot_Number = Range("WordArray").Cells(i, 4)
Suburb = Range("WordArray").Cells(i, 7)
Address = Range("WordArray").Cells(i, 11)
Town = Range("WordArray").Cells(i, 10)
Town_Check = Range("WordArray").Cells(i, 12)
Current_Date = Range("WordArray").Cells(i, 14)
DTC = Range("WordArray").Cells(i, 15)
Path = Range("Path")
Select Case Rail
Case "Blue Sun"
WordFileName = Range("FileNames").Cells(1, 1)
Case "Clenergy"
WordFileName = Range("FileNames").Cells(2, 1)
Case "Conergy"
WordFileName = Range("FileNames").Cells(3, 1)
Case "Sunlock"
WordFileName = Range("FileNames").Cells(4, 1)
End Select
Set wrdDoc = wrdApp.Documents.Open(Path & WordFileName, , True)
With wrdDoc
With .Bookmarks
.Item("Address").Range = Address
.Item("Current_date").Range = Current_Date
.Item("Job_1").Range = Job
.Item("Job_2").Range = Job
.Item("Lot_Number").Range = Lot_Number
.Item("Panel_Type").Range = Panel_Type
.Item("Panel_Type_2").Range = Panel_Type
.Item("Suburb").Range = Suburb
.Item("Town").Range = Town
.Item("Town_check").Range = Town_Check
If Customer = "Sunlock" Then
.Item("DTC").Range = DTC
End If
End With
wrdDoc.SaveAs (Path & "Lot " & Lot_Number & " " & Address & " " & Suburb & " " & Job & " - s40" & ".doc")
wrdDoc.ExportAsFixedFormat OutputFileName:=Path & "Lot " & Lot_Number & " " & Address & " " & Suburb & " " & Job & " - s40" & ".pdf", _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
.Close ' close the document
End With
Next
wrdApp.Quit ' close the Word application
Set wrdDoc = Nothing
Set wrdApp = Nothing
ScreenUpdating = True
End Sub
Solved it.
Needed to include the Microsoft Word 14.0 Object Library

Resources