report update - slicing an array into ROWS - any other methods?

[firatefe]

Hello All,

Just registered, first post ever here, thank you for taking the time. I know PhP & SQL at an intermediate level, new to VBA, so you will have to cut me some slack I searched the forum for similar queries however no luck.

I work in finances and try to provide my team with tools when necessary. I started making a tool recently but I am having some problems. The tool is composed of 2 excel files, one is database (data.xlsx) and the other one is user interface (issue tracker.xlsm). First macro in the interface file inserts values to database. Second macro in the interface file retrieves the report from database for user. It filters values by given criteria, copies the content and pastes it in a new sheet. The last macro, which I couldn't get my head around, is supposed to upload the data back to database.

I tried several solutions; firstly I tried to get the range to be updated into an array, get the range to be updated from database, and say database(x) = update(x), for example. Didn't work. I tried several different variations of arrays and ranges, nothing really works because either i need to nest 7 for each loops or I need to do an array inside an array, really not very good solutions in VBA. Lastly I tried to filter database table the same way i filter report, so i thought here i can go with visiblecells, however when i paste the data it goes to filtered cells in between. So I have to slice the datarange by rows definitely at least.

I will add all three macros here, in hopes that it will clarify and maybe help other people.

first macro

Sub addnew()

Dim lTest As Long, cn As WorkbookConnection
On Error Resume Next
For Each cn In ThisWorkbook.Connections
lTest = InStr(1, cn.OLEDBConnection.Connection, "Provider=Microsoft.Mashup.OleDb.1", vbTextCompare)
If Err.Number <> 0 Then
Err.Clear
Exit For
End If
If lTest > 0 Then cn.Refresh
Next cn

Application.ScreenUpdating = False

Sheet1.Activate

Dim process
Dim aff
Dim compcode
Dim historyid
Dim vendor
Dim vname
Dim doctype
Dim docno
Dim docdate
Dim reference
Dim amount
Dim cur
Dim pono
Dim owner
Dim comment

On Error Resume Next

process = Range("A2")
aff = Range("B2")
compcode = Range("C2")
historyid = Range("D2")
vendor = Range("E2")
vname = Range("F2")
doctype = Range("G2")
docno = Range("H2")
docdate = Range("I2")
reference = Range("J2")
amount = Range("K2")
cur = Range("L2")
pono = Range("M2")
comment = Range("N2")
owner = Range("O2")

Workbooks.Open ("data.xlsx")
Workbooks("data.xlsx").Activate

nextrow = ActiveSheet.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).Row
Cells(nextrow, 2).Value = process
Cells(nextrow, 3).Value = aff
Cells(nextrow, 4).Value = compcode
Cells(nextrow, 5).Value = historyid
Cells(nextrow, 6).Value = vendor
Cells(nextrow, 7).Value = vname
Cells(nextrow, 8).Value = doctype
Cells(nextrow, 9).Value = docno
Cells(nextrow, 10).Value = docdate
Cells(nextrow, 11).Value = reference
Cells(nextrow, 12).Value = amount
Cells(nextrow, 13).Value = cur
Cells(nextrow, 14).Value = pono
Cells(nextrow, 16).Value = comment
Cells(nextrow, 17).Value = owner

Dim lastrow
lastrow = ActiveSheet.UsedRange.Rows.count
Cells(nextrow, 1).Value = lastrow - 1

Dim EntryDate
EntryDate = Date
Cells(nextrow, 15).Value = EntryDate

Dim EndDate
EndDate = EntryDate + 14
Cells(nextrow, 24).Value = EndDate

Dim fuonedate
fuonedate = EntryDate + 2

If Weekday(fuonedate) = 1 Or Weekday(fuonedate) = 7 Then fuonedate = EntryDate + 4

Cells(nextrow, 19).Value = fuonedate

Cells(nextrow, 25).Value = "Open"

Workbooks("data.xlsx").Close SaveChanges:=True

Workbooks("issue tracker.xlsm").Activate
Cells.Range("A2:O2").Value = ""

Application.ScreenUpdating = True

End Sub

second macro (there is 8 of that, assigned to each button, reportowner is manipulated due to data privacy)

Sub generatereportbutton1()

Dim lTest As Long, cn As WorkbookConnection
On Error Resume Next
For Each cn In ThisWorkbook.Connections
lTest = InStr(1, cn.OLEDBConnection.Connection, "Provider=Microsoft.Mashup.OleDb.1", vbTextCompare)
If Err.Number <> 0 Then
Err.Clear
Exit For
End If
If lTest > 0 Then cn.Refresh
Next cn

Application.ScreenUpdating = False
Sheet1.Activate

Dim reportowner
reportowner = reportowner

On Error Resume Next

Workbooks.Open ("data.xlsx")
Workbooks("data.xlsx").Activate


Range("A:AA").AutoFilter Field:=17, _
    Criteria1:=reportowner, _
    VisibleDropDown:=False

Range("A:AA").AutoFilter Field:=25, _
    Criteria1:="Open", _
    Operator:=xlOr, _
    Criteria2:="Pending", _
    VisibleDropDown:=False


Range("A:AA").Copy Destination:=Workbooks("issue tracker.xlsm").Worksheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.count)).Range("A:AA")


Workbooks("data.xlsx").Close SaveChanges:=False

Workbooks("issue tracker.xlsm").Activate
ActiveSheet.Name = "Report"

    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).Name = _
        "Table1"
    Range("Table1[#All]").Select
    Dim querycheck
    Set querycheck = ActiveSheet.QueryTables("update").Select
    If querycheck = Not Null Then ActiveSheet.QueryTables("update").Delete
    ActiveWorkbook.Queries.Add Name:="Update", Formula:= _
        "let" & Chr(13) & "" & Chr(10) & "    Source = Excel.CurrentWorkbook(){[Name=""Table1""]}[Content]," & Chr(13) & "" & Chr(10) & "    #""Changed Type"" = Table.TransformColumnTypes(Source,{{""#"", Int64.Type}, {""Process"", type text}, {""AFF"", type text}, {""CC"", Int64.Type}, {""HID"", type any}, {""Vendor"", Int64.Type}, {""Name"", type text}, {""DOC Type"", type text}, {""DOC No"", Int64.Type}, {""DOC Date"", type dat" & _
        "etime}, {""Reference"", Int64.Type}, {""Amount"", type number}, {""CUR"", type text}, {""PO"", type text}, {""Entry Date"", type datetime}, {""Comments"", type text}, {""Owner"", type text}, {""Follow Up 1"", type text}, {""FU1 Date"", type datetime}, {""Follow Up 2"", type text}, {""FU2 Date"", type datetime}, {""Follow Up 3"", type any}, {""FU3 Date"", type dateti" & _
        "me}, {""End Date"", type any}, {""Status"", type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Changed Type"""
    Range("Y2").Select
    Range(Selection, Selection.End(xlDown)).Select
        With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=Dropdown!$F$2:$F$5"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With

Application.ScreenUpdating = True

End Sub

and last code which i couldn't figure out. I will put the version where it pastes the data after filtering, however pastes it to hidden cells as well, simply because my source range is more than 1 row. If i select source range row per row, then it should be okay, then I need a for each loop for update range.

Sub submitreport()

Dim lTest As Long, cn As WorkbookConnection
'On Error Resume Next
For Each cn In ThisWorkbook.Connections
lTest = InStr(1, cn.OLEDBConnection.Connection, "Provider=Microsoft.Mashup.OleDb.1", vbTextCompare)
If Err.Number <> 0 Then
Err.Clear
Exit For
End If
If lTest > 0 Then cn.Refresh
Next cn

Application.ScreenUpdating = False

Worksheets("Report").Activate

Dim reportowner
Set reportowner = Range("Q2")

Dim indexrange As Range
Dim indexarray() As Variant
Dim x As Long

Range("A2").Select
Set indexrange = Range(Selection, Selection.End(xlDown))

For Each cell In indexrange.Cells
indexarray() = indexrange.Cells.Value
x = x + 1
Next cell

Dim updaterange As Range
Dim lastcell As Range
Set lastcell = ActiveSheet.UsedRange.SpecialCells(xlLastCell)
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select

Set updaterange = Range(Selection, lastcell)

updaterange.Select

Dim updatearray() As Variant
Dim y As Long

For Each cell In updaterange.Cells
updatearray() = updaterange.EntireRow.Value
y = y + 1
Next cell


Workbooks.Open ("C:\Users\fefe\Desktop\TL\issue tracker\data.xlsx")
Workbooks("data.xlsx").Activate

Range("A:Y").AutoFilter Field:=17, _
    Criteria1:=reportowner, _
    VisibleDropDown:=False

Range("A:Y").AutoFilter Field:=25, _
    Criteria1:="Open", _
    Operator:=xlOr, _
    Criteria2:="Pending", _
    VisibleDropDown:=False

Dim firstcell As Range
Range("A2").Select

Selection.Offset(1, 0).Select
Do Until ActiveCell.EntireRow.Hidden = False
ActiveCell.Offset(1, 0).Select
Loop

Set firstcell = Selection

Dim i As Long, offvalue As Long

For i = 1 To updaterange.Rows.count
Do Until Not firstcell.Offset(offvalue).Rows.Hidden
offvalue = offvalue + 1
Loop
updaterange.Copy Destination:=firstcell.Offset(offvalue)
offvalue = offvalue + 1
Next i

Application.ScreenUpdating = True

End Sub

This code will paste first row of updaterange to each visible row, it will paste the whole thing three times as well. I guess I made a mistake somewhere in for each loop, have been working so much on that my brain became vapor.

Your help is greatly appreciated really Thanks a lot!!!

 

[firatefe]

bumping to up the post

 

[firatefe]

hello all,

i just fixed this on my own. maybe it will help someone else. below code does what i wanted

Sub submitreport()

Dim lTest As Long, cn As WorkbookConnection
'On Error Resume Next
For Each cn In ThisWorkbook.Connections
lTest = InStr(1, cn.OLEDBConnection.Connection, "Provider=Microsoft.Mashup.OleDb.1", vbTextCompare)
If Err.Number <> 0 Then
Err.Clear
Exit For
End If
If lTest > 0 Then cn.Refresh
Next cn

Application.ScreenUpdating = False

Worksheets("Report").Activate

Dim reportowner
Set reportowner = Range("Q2")

Dim indexrange As Range
Dim indexarray() As Variant
Dim x As Long

Range("A2").Select
Set indexrange = Range(Selection, Selection.End(xlDown))

For Each cell In indexrange.Cells
indexarray() = indexrange.Cells.Value
x = x + 1
Next cell

Dim updaterange As Range
Dim lastcell As Range
Set lastcell = ActiveSheet.UsedRange.SpecialCells(xlLastCell)
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select

Set updaterange = Range(Selection, lastcell)

updaterange.Select

Dim updatearray() As Variant
Dim y As Long

For Each cell In updaterange.Cells
updatearray() = updaterange.EntireRow.Value
y = y + 1
Next cell


Workbooks.Open ("C:\Users\fefe\Desktop\TL\issue tracker\data.xlsx")
Workbooks("data.xlsx").Activate

Range("A:Y").AutoFilter Field:=17, _
    Criteria1:=reportowner, _
    VisibleDropDown:=False

Range("A:Y").AutoFilter Field:=25, _
    Criteria1:="Open", _
    Operator:=xlOr, _
    Criteria2:="Pending", _
    VisibleDropDown:=False

Dim firstcell As Range
Range("A2").Select
Set firstcell = Selection
Selection.Offset(1, 0).Select

Do Until ActiveCell.EntireRow.Hidden = False
ActiveCell.Offset(1, 0).Select
Loop

Workbooks("issue tracker.xlsm").Activate
With Worksheets("Report")
Dim i As Long, offvalue As Long

For i = 1 To updaterange.Rows.count
Do Until Not firstcell.Offset(offvalue).Rows.Hidden
offvalue = offvalue + 1
Loop
Rows(i + 1).Copy Destination:=firstcell.Offset(offvalue)
offvalue = offvalue + 1
Next i
End With


Application.ScreenUpdating = True

End Sub