Xem recodset của CAD bên excel full

PHOTO

Mon Feb 17 2025 07:06:28 GMT+0000 (Coordinated Universal Time)

Saved by @kAnO #vba

Public Sub WatchRecordsetInExcel(rst As ADODB.Recordset)
    Dim objExcel
    Dim objWorkbook
    Dim objWorksheet
    Dim i As Long
    
    Set objExcel = CreateObject("Excel.Application")
    Set objWorkbook = objExcel.Workbooks.Add
    Set objWorksheet = objWorkbook.Worksheets("Sheet1")
    
    objExcel.visible = True
    
    With objWorksheet
        For i = 0 To rst.Fields.Count - 1
            objWorksheet.Range("A1").Offset(0, i).value = rst.Fields(i).Name
        Next i
        objWorksheet.Range("A2").CopyFromRecordset rst
    End With
    
    Set objWorksheet = Nothing
    Set objWorkbook = Nothing
    Set objExcel = Nothing
End Sub

Save snippets that work from anywhere online with our extensions

Available in the Chrome Web Store

Get Firefox Add-on

Get VS Code extension

Comments

More like this

ping and send Whatsapp message

Function Ping(strip)
Dim objshell, boolcode
Set objshell = CreateObject("Wscript.Shell")
boolcode = objshell.Run("ping -n 1 -w 1000 " & strip, 0, True)
If boolcode = 0 Then
    Ping = True
Else
    Ping = False
End If
End Function
Sub PingSystem()
Dim strip As String
Dim strPhoneNumber As String
Dim strMessage As String
Dim strPostData As String
Dim IE As Object

strPhoneNumber = Sheets("DATA").Cells(2, 1).Value

For introw = 2 To ActiveSheet.Cells(65536, 2).End(xlUp).Row
    strip = ActiveSheet.Cells(introw, 2).Value
    If Ping(strip) = True Then
        ActiveSheet.Cells(introw, 3).Interior.ColorIndex = 0
        ActiveSheet.Cells(introw, 3).Font.Color = RGB(0, 0, 0)
        ActiveSheet.Cells(introw, 3).Value = "Online"
        Application.Wait (Now + TimeValue("0:00:01"))
        ActiveSheet.Cells(introw, 3).Font.Color = RGB(0, 200, 0)
        
'Send Whatsapp Message
        strMessage = "Ping " & ActiveSheet.Cells(introw, 1).Value & " " & ActiveSheet.Cells(introw, 2).Value & " is Online"
        
'IE.navigate "whatsapp://send?phone=phone_number&text=your_message"
        strPostData = "whatsapp://send?phone=" & strPhoneNumber & "&text=" & strMessage
        Set IE = CreateObject("InternetExplorer.Application")
        IE.navigate strPostData
        Application.Wait Now() + TimeSerial(0, 0, 3)
        SendKeys "~"

        Set IE = Nothing
        
    Else
        ActiveSheet.Cells(introw, 3).Interior.ColorIndex = 0
        ActiveSheet.Cells(introw, 3).Font.Color = RGB(200, 0, 0)
        ActiveSheet.Cells(introw, 3).Value = "Offline"
        Application.Wait (Now + TimeValue("0:00:01"))
        ActiveSheet.Cells(introw, 3).Interior.ColorIndex = 6
        
'Send Whatsapp Message
        strMessage = "Ping " & ActiveSheet.Cells(introw, 1).Value & " " & ActiveSheet.Cells(introw, 2).Value & " is Offline"
        
'IE.navigate "whatsapp://send?phone=phone_number&text=your_message"
        strPostData = "whatsapp://send?phone=" & strPhoneNumber & "&text=" & strMessage
        Set IE = CreateObject("InternetExplorer.Application")
        IE.navigate strPostData
        Application.Wait Now() + TimeSerial(0, 0, 3)
        SendKeys "~"
        Set IE = Nothing
    End If
Next
End Sub

VBA to clear data from sheets

Sub ClearData()

Worksheets("Clients").Rows("2:" & Rows.Count).ClearContents
Worksheets("Cases").Rows("2:" & Rows.Count).ClearContents
Worksheets("Sessions").Rows("2:" & Rows.Count).ClearContents

End Sub

Sub PAUSE(Period As Single)
Dim TimeNow As Single
TimeNow = Timer
Do
    DoEvents
Loop While TimeNow + Period > Timer
End Sub

PPT manipulation VBA

Sub display_all_chart_shapes()

    Dim sld As Slide
    Dim shp As Shape
    Dim sr As Series
    Dim chrt As Chart
    Dim counter As Integer
    counter = 1
    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            Debug.Print counter & "##" & sld.Name & " " & shp.Name
        Next shp
        counter = counter + 1
    Next sld

End Sub

Function pieknosc()
    
    Dim sld As Slide
    Dim shp As Shape
    Dim sr As Series
    Dim chrt As Chart
    Dim counter As Integer
    counter = 1
    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            'Debug.Print counter & "##" & sld.Name & " " & shp.Name
            '
            '
            ' KOMENTARZE
            '
            '
            If shp.Name = "TextBox 11" Then
                Debug.Print counter & "##" & sld.Name & " " & shp.Name & "left: " & shp.Left & "top: " & shp.Top & "width: " & shp.Width
                sngDefaultSlideWidth = ActivePresentation.PageSetup.SlideWidth
                sngDefaultSlideHeight = ActivePresentation.PageSetup.SlideHeight
                'shp.Left = (sngDefaultSlideWidth / 2 - shp.Width) / 2 + sngDefaultSlideWidth / 2
                'shp.Top = (sngDefaultSlideHeight / 2 - shp.Height) / 2 + 8 + sngDefaultSlideHeight / 2
                shp.Left = 10
                shp.Top = 460
                shp.Width = 720
                shp.TextEffect.FontName = "Arial"
                shp.TextEffect.FontSize = 9
            End If
            '
            '
            ' PODTYTUŁY
            '
            '
            If shp.Name = "Podtytuł 2" Then
                Debug.Print counter & "##" & sld.Name & " " & shp.Name & "left: " & shp.Left & "top: " & shp.Top & "width: " & shp.Width
                sngDefaultSlideWidth = ActivePresentation.PageSetup.SlideWidth
                sngDefaultSlideHeight = ActivePresentation.PageSetup.SlideHeight
                'shp.Left = (sngDefaultSlideWidth / 2 - shp.Width) / 2 + sngDefaultSlideWidth / 2
                'shp.Top = (sngDefaultSlideHeight / 2 - shp.Height) / 2 + 8 + sngDefaultSlideHeight / 2
                shp.Left = 10
                shp.Top = 10
                shp.Width = 900
                shp.TextEffect.FontName = "Arial"
                shp.TextEffect.FontSize = 24
            End If
            
            
            
        Next shp
        counter = counter + 1
    Next sld
End Function

PYTHON pdf to csv

import tabula
df = tabula.read_pdf(r'C:\Users\igrod\Downloads\tabela nieruchomosci.pdf', pages='all')
tabula.convert_into(r'C:\Users\igrod\Downloads\tabela nieruchomosci.pdf', r'C:\Users\igrod\Downloads\tabela nieruchomosci.csv', output_format="csv", pages='all')

VBA define a range as a variable and fill with random numbers

Sub rangething()

Dim myrange As range

Set myrange = range("B5:H10")
myrange.Value = "=rand()"

End Sub

Populate range with random numbers and calculate the avg and sum

Sub populaterange()

Dim myrange As range

Set myrange = range("C2:J12")
myrange.Value = "=rand()"

range("C14").Value = "Average"
range("D14").Formula = WorksheetFunction.Average(myrange)

range("C15").Value = "Sum"
range("D15").Formula = WorksheetFunction.Sum(myrange)

End Sub

Dim i As Integer

For i = 3 To 26
If Cells(i, 2) >= 0.5 Then
Cells(i, 3).Value = "Upper"
Cells(i, 3).Font.Bold = True
End If
Next i

End Sub

Sub cumulate()

Dim i As Integer

Range("D3").Value = Range("B3").Value

For i = 4 To 26
Cells(i, 4) = Cells(i - 1, 4) + Cells(i, 2)
Next i

End Sub

2 dimensional array, monte carlo sims

Option Explicit

Sub mcSim()

' This sub will populate a 30x10 array with
' values according to the formula in the revision
' lecture

    Dim mcSim(1 To 30, 1 To 10) As Double, mu As Double
    Dim sd As Double, i As Integer, j As Integer


' Here you want to set the mean and stddev
' to whichever cell contains your inputs

    mu = 0.000238095
    sd = 0.008819171
    
    Randomize
    
    For j = 1 To 10
        For i = 1 To 30
            mcSim(i, j) = mu + sd * WorksheetFunction.Norm_S_Inv(Rnd)
        Next i
    Next j

    Range("I6").Resize(30, 10) = mcSim


End Sub

Option Explicit

Sub mcSim()

    Dim mcSim(1 To 63, 1 To 30) As Double, mu As Double
    Dim sd As Double, i As Integer, j As Integer

    mu = Range("C11")
    sd = Range("C12")
    
    Randomize
    
    'fill 2x2 array
    
    For j = 1 To 30
        For i = 1 To 63
            mcSim(i, j) = mu + sd * WorksheetFunction.Norm_S_Inv(Rnd)
        Next i
    Next j

    Range("F4").Resize(63, 30) = mcSim

    'label 2x2 array
    
    For j = 1 To 30
        For i = 1 To 63
            Cells(i + 3, 5) = i
            Cells(3, j + 5) = j
        Next i
    Next j

    
End Sub

Sub valuecalcs()

Dim col As Integer, row As Integer
Dim myrange As Range

For col = 6 To 35
    For row = 4 To 66
        Cells(row, 37) = 1 + Cells(row, col)
    Next row
    
    Set myrange = Range(Cells(4, 37), Cells(66, 37))
    Cells(68, col) = WorksheetFunction.Product(myrange)
Next col
    
Range("E68").Value = "Future value of R1"

End Sub

Sub valuecalcs2()

Dim col As Integer, row As Integer
Dim myrange As Range

Range("E69").Value = "ST"
Range("E70").Value = "X"
Range("E71").Value = "Max(ST-X,0)"
Range("E72").Value = "DCF"
Range("E74").Value = "Average DCF"


For col = 6 To 35
    Cells(69, col) = WorksheetFunction.Product(Cells(68, col), Cells(3, 3))
    Cells(70, col) = Range("C7")
    If Cells(69, col) - Cells(70, col) <= 0 Then
        Cells(71, col) = 0
        Else
            Cells(71, col) = Cells(69, col) - Cells(70, col)
        End If
    Cells(72, col) = WorksheetFunction.Product(Cells(71, col), Cells(14, 3))
    Next col
    
Set myrange = Range(Cells(72, 6), Cells(72, 35))
Cells(74, 6) = WorksheetFunction.Average(myrange)
    
End Sub

Option Explicit
Sub mcSim()

    range("C16").Clear
    range("E3", "AL100").Clear

    Dim mcSim() As Double, mu As Double, iters As Integer, time As Integer
    Dim sd As Double, row As Integer, col As Integer

    
    time = InputBox("On which day would you like to exercise your option? (select a number between 1 and 63)")
    
    ReDim mcSim(1 To time, 1 To 30)
    iters = range("C17")
    range("B16").Value = "Selected exercise day"
    range("C16").Value = time

' Here you want to set the mean and stddev
' to whichever cell contains your inputs

    mu = range("C11")
    sd = range("C12")
    
    Randomize
    
   'i is rows, j is cols
   
    For col = 1 To iters
        For row = 1 To time
            mcSim(row, col) = mu + sd * WorksheetFunction.Norm_S_Inv(Rnd)
        Next row
    Next col

    range("F4").Resize(time, iters) = mcSim

    'label 2x2 array
    
    For col = 1 To 30
        For row = 1 To time
            Cells(row + 3, 5) = row
            Cells(3, col + 5) = col
        Next row
    Next col
    
    range("E3").Value = "Day"
    range(Cells(3, 5), Cells(time + 3, 5)).Interior.ColorIndex = 24
    range(Cells(3, 5), Cells(time + 3, 5)).HorizontalAlignment = xlCenter
    
End Sub
Sub FV1rand()

Dim col As Integer, row As Integer
Dim myrange As range
Dim time As Integer

time = range("C16")

For col = 6 To 35
    For row = 4 To time + 3
        Cells(row, 37) = 1 + Cells(row, col)
    Next row
    
    Set myrange = range(Cells(4, 37), Cells(time + 3, 37))
    Cells(time + 5, col) = WorksheetFunction.Product(myrange)
Next col
    
Cells(time + 5, 5) = "Future value of R1"
Cells(time + 5, 5).Interior.ColorIndex = 24

End Sub

Sub valuecalcs()

Dim col As Integer, row As Integer
Dim myrange As range
Dim time As Integer

time = range("C16")

Cells(time + 6, 5) = "ST"
Cells(time + 7, 5) = "X"
Cells(time + 8, 5) = "Max(ST-X,0)"
Cells(time + 9, 5) = "DCF"
Cells(time + 11, 5) = "Average DCF"


For col = 6 To 35
    Cells(time + 6, col) = WorksheetFunction.Product(Cells(time + 5, col), Cells(3, 3))
    Cells(time + 7, col) = range("C7")
    If Cells(time + 6, col) - Cells(time + 7, col) <= 0 Then
        Cells(time + 8, col) = 0
        Else
            Cells(time + 8, col) = Cells(time + 6, col) - Cells(time + 7, col)
        End If
    Cells(time + 9, col) = WorksheetFunction.Product(Cells(time + 8, col), Cells(14, 3))
    Next col
    
Set myrange = range(Cells(time + 9, 6), Cells(time + 9, 35))
Cells(time + 11, 6) = WorksheetFunction.Average(myrange)

Cells(time + 6, 5).Interior.ColorIndex = 24
Cells(time + 7, 5).Interior.ColorIndex = 24
Cells(time + 8, 5).Interior.ColorIndex = 24
Cells(time + 9, 5).Interior.ColorIndex = 24
Cells(time + 11, 5).Interior.ColorIndex = 17
Cells(time + 6, 5).HorizontalAlignment = xlCenter
Cells(time + 7, 5).HorizontalAlignment = xlCenter
Cells(time + 8, 5).HorizontalAlignment = xlCenter
Cells(time + 9, 5).HorizontalAlignment = xlCenter
Cells(time + 11, 5).HorizontalAlignment = xlCenter
    
End Sub

Option Explicit

Function bscholes(rf As Double, so As Double, X As Double, sd As Double) As Double

Dim d1 As Double, d2 As Double, nd1 As Double, nd2 As Double, c As Double

d1 = (Log(so / X) + (rf + 0.5 * sd * sd) * 0.25) / (sd * Sqr(0.25))
d2 = d1 - (sd * Sqr(0.25))
nd1 = WorksheetFunction.Norm_S_Dist(d1, True)
nd2 = WorksheetFunction.Norm_S_Dist(d2, True)
c = so * nd1 - X * Exp(-rf * 0.25) * nd2

bscholes = c

End Function

Option Explicit

Sub q4()

 Dim q4a(1 To 25, 1 To 25) As Double
 Dim col As Integer, row As Integer
 
 For col = 1 To 25
 For row = 1 To 25
    q4a(row, col) = WorksheetFunction.RandBetween(100, 1000)
 Next row
 Next col
  
 range("B2").Resize(25, 25) = q4a

End Sub

Function exammax(bigrange As range) As String

Dim cell As range, maxval As Double

Set bigrange = range("B2:Z26")
maxval = range("B2")

For Each cell In bigrange
 If cell >= maxval Then maxval = cell
Next cell

exammax = maxval

End Function

Function exammin(bigrange As range) As String

Dim cell As range, minval As Double

Set bigrange = range("B2:Z26")
minval = range("B2")

For Each cell In bigrange
 If cell <= minval Then minval = cell
Next cell

exammin = minval

End Function

Sub sortino()

Dim bigrange As range, cell As range, counter As Integer, cellmean As Double

Set bigrange = range("B2:Z26")
cellmean = WorksheetFunction.Average(bigrange)
counter = 2

For Each cell In bigrange
    If cell <= cellmean Then
    Cells(28, counter) = cellmean - cell
    counter = counter + 1
    End If
    Next cell

range("A31") = "sortino ratio"
range("B31") = WorksheetFunction.Average(range(Cells(28, 2), Cells(28, counter)))

End Sub

Regex for Access

Dim RegEx As Object
Set RegEx = CreateObject("vbscript.regexp")

RegEx.Pattern = "\[UserID\]=([0-9]+)"
Set qdef = getCurrentDb.QueryDefs("Query Course List PASSTHRU")
qdef.SQL = RegEx.Replace(qdef.SQL, "[UserID]=" & getLoggedInUserID)


Query:
[Cost Centre Descriptions].[Sector Code] IN (

SELECT [SectorCode]
FROM [tbl_TRNG_PermissionsBySector] WITH (NOLOCK)
WHERE [UserID]=9999 AND ViewSector=1

)

Build Pass through query using Regex to replace Form fields in query

Private Sub Select_Sector()

Dim rs As DAO.Recordset

Dim RegEx As Object
Set RegEx = CreateObject("vbscript.regexp")

Dim qdef As QueryDef
Set qdef = getCurrentDb.QueryDefs("qry_Select_Sector")
qdef.Connect = CurrentDb.TableDefs("BOCClientIndex").Connect


RegEx.Pattern = "IIf\(\[ServiceStatus\]=3,30,20\)\)=([0-9]+)"
qdef.SQL = RegEx.Replace(qdef.SQL, "IIf([ServiceStatus]=3,30,20))=" & [Forms]![MainMenu_Services]![SelectedStatusIndicator])

RegEx.Pattern = "\(View_qryServiceProviderOrganisationalStructure\.SectorCode\)=([0-9]+)"
qdef.SQL = RegEx.Replace(qdef.SQL, "(View_qryServiceProviderOrganisationalStructure.SectorCode)=" & [Forms]![MainMenu_Services]![SectorCode])


'For Testing purposes only - Do not use in production code
Set rs = qdef.OpenRecordset

Dim i As Long
For i = 0 To rs.Fields.Count - 1
        Debug.Print rs.Fields(i).Name,
    Next
    rs.MoveFirst
    Do Until rs.EOF
        Debug.Print
        For i = 0 To rs.Fields.Count - 1
            Debug.Print rs.Fields(i).value,
        Next
        rs.MoveNext
    Loop
End Sub

Browse more snippets >>