Quantcast
Channel: Excel VBA Codes & Macros
Viewing all 52 articles
Browse latest View live
↧

Export Range to Pipe Delimit Text File

August 1, 2014, 11:23 pm
$
0
0
Macro to export range to pipe delimit textfile -


Option Base 1
Option Explicit
Sub export_range_pipe_delimit()
Dim arr As Variant
Dim i As Long, j As Long
Dim line As String
Dim filename As String
Dim rng As Range
Dim fnum

filename = "C:\Users\ashishkoul\Desktop\Pipe Delimit\sample.txt"' change file_path here
fnum = FreeFile()
Open filename For Output As fnum
Set rng = Range("a1:ah40000") ' Change range here
arr = rng
For j = LBound(arr) To UBound(arr)
    line = ""
    For i = 1 To rng.Columns.Count
        line = line & "|"& arr(j, i)
    Next
   
    Print #fnum, Right(line, Len(line) - 1)
Next
Close #fnum
End Sub
↧
Search

UDF to Check Cell is having Validation or not

August 5, 2014, 6:44 am
$
0
0
UDF To Check Cell is having validation or not:



Function is_validation(rng As Range) As Boolean
    Dim i
 
    On Error Resume Next
    i = rng.Validation.Type
    On Error GoTo 0
  
    If i = 3 Then
        is_validation = True
    Else
        is_validation = False
    End If
End Function

Use it like =is_validation(D3)
↧
↧

Export Range in Json Format

January 31, 2015, 2:11 am
$
0
0
Macro to Export Range in Json Format


Option Explicit

Sub export_in_json_format()

    Dim fs As Object
    Dim jsonfile
    Dim rangetoexport As Range
    Dim rowcounter As Long
    Dim columncounter As Long
    Dim linedata As String
   
    ' change range here
    Set rangetoexport = Sheet1.Range("a1:d8")
   
    Set fs = CreateObject("Scripting.FileSystemObject")
    ' change dir here
   
    Set jsonfile = fs.CreateTextFile("C:\Users\xx\Desktop\"& "jsondata.json", True)
   
    linedata = "{""Output"": ["
    jsonfile.WriteLine linedata
    For rowcounter = 2 To rangetoexport.Rows.Count
        linedata = ""
        For columncounter = 1 To rangetoexport.Columns.Count
            linedata = linedata & """"& rangetoexport.Cells(1, columncounter) & """"& ":"& """"& rangetoexport.Cells(rowcounter, columncounter) & """"& ","
        Next
        linedata = Left(linedata, Len(linedata) - 1)
        If rowcounter = rangetoexport.Rows.Count Then
            linedata = "{"& linedata & "}"
        Else
            linedata = "{"& linedata & "},"
        End If
       
        jsonfile.WriteLine linedata
    Next
    linedata = "]}"
    jsonfile.WriteLine linedata
    jsonfile.Close
   
    Set fs = Nothing
   
   
End Sub
↧

Import Data from Access Table

March 21, 2015, 2:55 am
$
0
0
Macro to import data from access table using Excel VBA


Option Explicit

Sub import_data()
    ' Tools Refrences set microsoft active x object
    ' clear exiting data
    Sheet1.Range("a1").CurrentRegion.Clear
    ' call sub proc to import data pass three parameters
    ' 1st query
    ' 2nd range/location for import
    ' 3rd True, False to import column/field names
    Call get_data("select * from tbl_sample", Sheet1.Range("a1"), 1)
End Sub


Sub get_data(strQry As String, rng_to_paste As Range, fld_name As Boolean)
    Dim rs As ADODB.Recordset
    Dim cnn As ADODB.Connection
    Dim i As Long
    Dim dbpath As String
    Set rs = New ADODB.Recordset
    Set cnn = New ADODB.Connection
  
    dbpath = ThisWorkbook.Path & "\database.accdb"
  
    ' create the connection
    With cnn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .Open dbpath
    End With
  
    rs.CursorLocation = adUseClient
    rs.cursortype = adOpenDynamic
    rs.locktype = adLockOptimistic
  
    rs.Open strQry, cnn
  
        If fld_name = True Then
      
        For i = 1 To rs.Fields.Count
            rng_to_paste.Offset(0, i - 1).Value = rs.Fields(i - 1).Name
        Next
            rng_to_paste.Offset(1, 0).CopyFromRecordset rs
        Else
            rng_to_paste.CopyFromRecordset rs
        End If
  
    rs.Close
    cnn.Close
End Sub
↧

Append Data to Access Table from Excel

March 21, 2015, 9:31 am
$
0
0
Macro to export Excel range to Access table

Sub export_data()
    ' table to insert, workbook ,range to export
    Call insert_data("tbl_sample", ThisWorkbook, Sheet1.Range("a1:b9"))
End Sub


Sub insert_data(tablename As String, wkb As Workbook, rng As Range)

    Dim cnn As ADODB.Connection
    Dim workbookname As String
    Dim sqlstring As String
    Dim rngtoinsert As String
    Dim dbpath As String
    Dim columnnames As String
    Dim columncounter As Integer
    
    Set cnn = New ADODB.Connection

    dbpath = ThisWorkbook.Path & "\database.accdb"
    workbookname = wkb.FullName
    rngtoinsert = "["& rng.Parent.Name & "$"& rng.Address(0, 0) & "]"
    
    ' extract column/field names
    For columncounter = 1 To rng.Columns.Count
        columnnames = columnnames & "["& rng.Cells(1, columncounter).Value & "],"
    Next
    columnnames = Left(columnnames, Len(columnnames) - 1)
    
    ' create connection
    cnn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="& dbpath
    cnn.Open cnn

    ' add data to access table
    sqlstring = "INSERT INTO "& tablename & "("& columnnames & ") "
    sqlstring = sqlstring & "SELECT * FROM [Excel 12.0;HDR=YES;DATABASE="& workbookname & "]."& rngtoinsert
    
    ' execute command and close connection
    cnn.Execute sqlstring
    cnn.Close


End Sub
↧
↧

Update Access Table from Excel using VBA

March 28, 2015, 11:46 am
$
0
0
Macro to update access database using Update query in Excel VBA


Sub run_sql()
    Dim sqlquery As String
    sqlquery = "UPDATE tbl_sample SET tbl_sample.rname = ""a"" WHERE [tbl_sample.rname]=""z1"";"
    Call edit_data(ThisWorkbook.Path & "\database.accdb", sqlquery)
End Sub


Sub edit_data(dbpath As String, sqlstring As String)

    Dim cnn As ADODB.Connection
    Set cnn = New ADODB.Connection

    With cnn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .Open dbpath
    End With
 
    ' execute command and close connection
    cnn.Execute sqlstring
    cnn.Close

End Sub
↧

Type your Sql Query In inputbox in excel and import data from access to excel

March 28, 2015, 12:14 pm
$
0
0
Type Sql Query in input box and import data to excel from Access Table





Sub import_data()
    ' Tools Refrences set microsoft active x object
    ' clear exiting data
    Dim sqlstring As String
    Sheet1.Range("a1").CurrentRegion.Clear
    sqlstring = InputBox("Enter the Query")
    Call get_data(sqlstring, Sheet1.Range("a1"), 1)
End Sub


Sub get_data(strQry As String, rng_to_paste As Range, fld_name As Boolean)
    Dim rs As ADODB.Recordset
    Dim cnn As ADODB.Connection
    Dim i As Long
    Dim dbpath As String
    Set rs = New ADODB.Recordset
    Set cnn = New ADODB.Connection
  'change database path here
    dbpath = ThisWorkbook.Path & "\database.accdb"
 
    ' create the connection
    With cnn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .Open dbpath
    End With
 
    rs.CursorLocation = adUseClient
    rs.cursortype = adOpenDynamic
    rs.locktype = adLockOptimistic
 
    rs.Open strQry, cnn
 
        If fld_name = True Then
     
        For i = 1 To rs.Fields.Count
            rng_to_paste.Offset(0, i - 1).Value = rs.Fields(i - 1).Name
        Next
            rng_to_paste.Offset(1, 0).CopyFromRecordset rs
        Else
            rng_to_paste.CopyFromRecordset rs
        End If
 
    rs.Close
    cnn.Close
End Sub
↧

Modify Access Table using recordset in Excel VBA

March 28, 2015, 1:24 pm
$
0
0
Macro to modify access table using record-set in Excel VBA



Sub update_access_table()
    ' Tools Refrences set microsoft active x object
    ' clear exiting data
    ' run query using where clause , field name and new value
    Call edit_data("select * from tbl_sample where rname ='d'", "rname", "newvalue")
End Sub


Sub edit_data(strQry As String, fieldname As String, newvalue As String)
    Dim rs As ADODB.Recordset
    Dim cnn As ADODB.Connection
    Dim dbpath As String
   
    Set rs = New ADODB.Recordset
    Set cnn = New ADODB.Connection
 
    dbpath = ThisWorkbook.Path & "\database.accdb"
 
    ' create the connection
    With cnn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .Open dbpath
    End With
 
    With rs
        .CursorLocation = adUseClient
        .cursortype = adOpenDynamic
        .locktype = adLockOptimistic
        .Open strQry, cnn
        If .EOF Then Exit Sub
        .MoveFirst
        Do Until .EOF
            .Fields(fieldname).Value = newvalue
            .Update
            .MoveNext
        Loop
        .Close
    End With
    cnn.Close
End Sub
↧
Search

Connect states with arrows US Map using X Y Scatter Chart

June 7, 2015, 12:10 am
$
0
0
Create connections on map using X Y Scatter



Download the working file here 

https://app.box.com/s/6oks8mpammnza49tg3k6luhgx7rc5ybp




Code to create connections:

Option Compare Text
Option Explicit

' for any query contact koul.ashish@gmail.com


Sub create_chart()

    Dim srs As Series
    Dim ap As Points
    Dim valtocheck As String
    Dim i As Long
   
    Sheets("Map").Unprotect
    Charts("Map").Select

   
    valtocheck = Sheets("Database").Range("state_selected").Value
   
    If Application.WorksheetFunction.CountIf(Sheets("Source Data").Range("A:A"), valtocheck) = 0 Then
        MsgBox "Please make sure selected state data is added on source data tab", vbInformation, "Note:"
        Exit Sub
    End If
   
    ' xxxxxxxxxxxxxxxxxxxxx delete existing series
       
    For Each srs In ActiveChart.SeriesCollection
        srs.Delete
    Next srs
       
      
    ' XXXXXXXXXXXXXXX adding series to charts
   
    With Sheets("Source Data")
        For i = 4 To .Range("a65356").End(xlUp).Row
            If .Range("a"& i).Value = valtocheck Then
                Set srs = ActiveChart.SeriesCollection.NewSeries
                srs.Name = "='Source Data'!$E$"& i
                srs.XValues = "='Source Data'!$B$"& i & ",'Source Data'!$F$"& i
                srs.Values = "='Source Data'!$C$"& i & ",'Source Data'!$G$"& i
                ' xxxxxxx formatting the series
                srs.Border.Color = vbRed
                With srs.Format.Line
                    .Weight = 1
                    .EndArrowheadStyle = msoArrowheadTriangle
                    .DashStyle = msoLineDashDot
                    .EndArrowheadWidth = msoArrowheadWide
                End With
                srs.Smooth = True
            End If
        Next i
    End With
   
    Sheets("Map").Protect
End Sub
↧
↧

Create Sunburst chart in Excel

June 21, 2015, 1:22 am
$
0
0
Create Sunburst Chart in Excel using Doughnut


 





Steps to create

  1. Download the template  link
  2. Make sure data is sorted
  3. Click on prepare data button
  4. Choose the level from the drop -down
  5. Select the chart to activate the mouse over effect
 
The chart is created using Doughnut chart and each level is added as a series in it. The macro is used to prepare the chart data and add the series to charts dynamically as per the selected level. You can add further levels in the chart all you need to do is create the sheets like level 1, level 2 ,etc which are already existing in the template and make the changes in the code as per the requirement



    ↧

    Filter rows on comment text

    September 26, 2015, 7:02 am
    $
    0
    0
    Macro to hide and unhide the rows on comment text


    Option Compare Text

    Sub filteroncomments()

    Dim commenttext As String
    Dim commentrng As Range
    Dim cl As Range

    With ActiveSheet
        .FilterMode = False
        .UsedRange.EntireRow.Hidden = False
        On Error Resume Next
        Set commentrng = ActiveSheet.UsedRange.SpecialCells(xlCellTypeComments)
        On Error GoTo 0
        If commentrng Is Nothing Then
            MsgBox "No comments on worksheet"
            Exit Sub
        End If
       
       
        Application.Calculation = xlCalculationManual
       
        .UsedRange.EntireRow.Hidden = True
       
        commenttext = InputBox("Enter comment to search")
       
        For Each cl In commentrng
            If cl.EntireRow.Hidden = True Then
                If InStr(cl.Comment.Text, commenttext) > 0 Then cl.EntireRow.Hidden = False
            End If
           
        Next
       
        Application.Calculation = xlCalculationAutomatic

    End With


    End Sub
    ↧

    Import data from SQL

    December 13, 2016, 10:12 am
    $
    0
    0
    Macro to import data from SQL using ADO connection string:

    Sub Import_data_from_SQL()

    ' Tools -> References -> Microsoft Active Data object 2.0
    Dim rs As ADODB.Recordset
    Dim cnn As ADODB.Connection

    Dim sConnString As String

    Set rs = New ADODB.Recordset
    Set cnn = New ADODB.Connection

    ' create the connection
    'Server=;UserID=myUsername;password=myPassword;
    sConnString = "Provider=SQLOLEDB;Data Source=servername;"& _
                  "Initial Catalog=NORTHWIND;"& _
                  "Integrated Security=SSPI;"
    'Open connection
    cnn.Open sConnString

    strQry = "SELECT * FROM ORDERS"
    With rs
        .CursorLocation = adUseClient
        .CursorType = adOpenDynamic
        .LockType = adLockOptimistic
        .Open strQry, cnn
    End With

    'paste data
    Sheets(1).Range("A1").CopyFromRecordset rs

    'close
    rs.Close
    cnn.Close

    End Sub



    ↧
    Viewing all 52 articles
    Browse latest View live
    Search