Dane z zamkniętego arkusza recordset adodb

'przy poocy takiej funkcji można na spokojności wysłać zapytanie SQL do zamkniętego pliku Excel
'i uzyskać w odpowiedzi żądane dane
'wywałać funkcję można w taki sposób:
'Set rst = GetRS(pełnaŚcieżka, stSQl, opcjonalnie nazwa pliku), gdzie definiujemy rst jako ADODB.Recordset (Dim rst As ADODB.Recordset)

Function GetRS(wbkTocopy As String, stsql As String, Optional e As String)
As ADODB.Recordset

Dim rst As ADODB.Recordset
Dim stcon As String
Set rst = New ADODB.Recordset

On Error GoTo errPR
stcon = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & wbkTocopy & ";" & _
"Extended Properties='Excel 12.0;HDR=YES'"

rst.Open stsql, stcon, adOpenStatic
If rst.EOF Or rst.BOF Then Exit Function ' sprawdzam czy są rekordy w recordsecie (czy nie jest pusty)

rst.MoveLast ''ten krok
rst.MoveFirst ''i ten służą do naprawienia błędu recotdset.count -1
Set GetRS = rst

Set rst = Nothing
stcon = Empty
normalExit:
Exit Function

errPR:
MsgBox "something went wrong, probably sheet name in: " & e, vbExclamation
End
End Function

‘dwie pętle, robiące dokładnie to samo
iFieldCount = rst.Fields.Count
For i = 1 To iFieldCount
objSheet.Range("A" & i) = rst.Field(i).Name
Next i

‘***********************************

‘’Call addHeadrers(ws, rst)
Sub addHeadrers(ws As Worksheet, rst As ADODb.Recordset)
Dim r
Dim a As Long
a = 1

For Each r In rst.Fields
ws.Cells(1, a).Value = r.Name
a = a + 1
Next

End Sub

Rst.recordcount ‘’’’jeżeli wychodzi -1, to warto zrobić rst.movelast, rst.move first, pomaga

Sheets(1).cells(1,1).copyfromrecordset rst ‘’’’ generalnie wybieramy pierszą komórkę, w którą zostaną wklejone dane

‘ jako from dajemy nazwę arkusza w danym pliku, w miejscu gwiazdki dajemy nazwy kolumn
stsql = "SELECT * from [Sheet1$]"

Set rst = GetRS(fullfilePath, stsql)

For a = 1 to rst.recordcount
Rst.move a
‘’’’tu robimy akcję, jakąkolwiek, ja np dodawałem do słowniczka rzeczy do kontroli,
‘’ tak, losowałem sobie próbki do sprawdzenia przy pomocy recordset’a
‘’ gdy miałem wylosowane a, to sprawdzałem czy znajduje się w słowniczku (scripting dictionary)
‘’ if not d.exists , then d.add ….
‘’scripting.dictionary będzie w dalszej części
Rst.MoveFirst ‘ wracamy do początku
Next
'albo
rs.MoveFirst 'niekoniecznie musi być, ale warto wyrobić sobie taki nawyk :)
Do Until rs.EOF = True
'akcja np Debug.Print rs.Fields("nazwa Kolumny")
rs.MoveNext 'przechodzimy do kolejnego rekordu
Loop

lastcolumn = Data_sht.Cells(1, Data_sht.Columns.Count).End(xlToLeft).Column ‘ ostatnia kolumna w pierwszym wierszulastrow = Data_sht.Cells(Data_sht.Rows.Count, 13).End(xlUp).Row ‘ ostatni wiersz w 13 kolumnie (M)

Set Destwb = thisworkbook
Scieżka = “C:\”
Name = “przykładowaNazwaPliku”
‘spradzamy z której wersji excela korzystamy
With Destwb
If Val(Application.Version) < 12 Then ‘ 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With

Destwb.SaveAs scieżka < name < FileExtStr, FileFormat:=FileFormatNum

Function IsWorkBookOpen(FileName As String) As Boolean
Dim ff As Long, ErrNo As Long

On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0

Select Case ErrNo
Case 0: IsWorkBookOpen = False 'nikt nie używa pliku
Case 70: IsWorkBookOpen = True ' plik jest w użyciu
Case Else: Error ErrNo
End Select
End Function

'przy użyciu tej pętli można w żadane komórki wrzucić skróconą nazwę miesiąca, pisaną wielką literą, z dwukropkiem oraz ją pogrubić i zmienić kolor na niebieski
For a = 2 To lastrow ''lastrow = ostatni wiersz :)
ws.Cells(a, 3).Value = VBA.Format(VBA.Now, "Mmm") & ":"
ws.Cells(a, 3).Characters(1, 1).Caption = VBA.UCase(ws.Cells(a, 3).Characters(1, 1).Caption)
If Not c.Characters.Count < 3 Then

ws.Cells(a, 3).Characters(1, 3).Font.Bold = True
ws.Cells(a, 3).Characters(1, 3).Font.Color = RGB(16, 16, 146)

End If
Next

Sub InsertCheckBoxes()

Dim Rng As Range
Dim WorkRng As Range
Dim Ws As Worksheet
'poniższa procedura wstawia w każdą komórkę tabeli 'tblOferta' 'L.P', checkbox, idealnie dopasowany do rozmiaru komórki, oraz łączy dany checkbox z komórką w w kolumnie "n" w tym samym wierszu (dopóki komórka 4 kolumny w prawo nie będzie pusta)
Set Ws = ThisWorkbook.Sheets("Oferta")
Application.ScreenUpdating = False
Application.EnableEvents = False


For Each Rng In Ws.Range("tblOferta[L.P.]").Cells
If Rng.Offset(, 4).Value = "" Then Exit For
With Ws.CheckBoxes.Add(Rng.Left, Rng.Top, Rng.Width, Rng.Height)
.Characters.Text = ""
.Value = xlOff
.LinkedCell = "$N$" & Rng.Row
.Display3DShading = False
End With

Next
Set Ws = Nothing
Set Rng = Nothing

Application.EnableEvents = True

Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'pracedurka, która dla komórek w danem zakresie (u mnie tabela "tblOferta") będzie wciskać f2 - innymi słowy single click cell edit (jeżeli arkusz nie jest zabezpieczony Oraz zaznaczona jest jedna komórka)
On Error GoTo exitssusfd
If Target.Cells.Count = 1 Then
If Not Intersect(Target, Me.Range("tblOferta")) Is Nothing And Intersect(Target, Me.Range("tblOferta[rabat?]")) Is Nothing And Target.Value <> "" Then

If Me.ProtectContents = True Then
>If> Target.Locked = False Then
SendKeys "{F2}"
End If
Else
SendKeys "{F2}"
End If
End If

End If
exitssusfd:
End Sub