Rushikesh – ExcelMacroClasses.com https://www.excelmacroclasses.com An Online Excel Solution Thu, 27 Feb 2025 13:24:40 +0000 en-US hourly 1 https://wordpress.org/?v=6.7.2 https://www.excelmacroclasses.com/wp-content/uploads/2024/04/cropped-cropped-cropped-Original-Logo-S-32x32.jpg Rushikesh – ExcelMacroClasses.com https://www.excelmacroclasses.com 32 32 VBAHELP https://www.excelmacroclasses.com/vbahelp/ Thu, 27 Feb 2025 12:50:57 +0000 https://www.excelmacroclasses.com/?p=293 This is only for temporary code.


Private Sub lstUserWP_Click()
    iRow = lstUserWP.ListIndex
    txtDepartment.value = lstUserWP.List(iRow, 3)
    txtRegion.value = lstUserWP.List(iRow, 4)
    txtWorkProcess.value = lstUserWP.List(iRow, 1)
    txtDescription.value = lstUserWP.List(iRow, 2)
End Sub
Private Sub btnLoadDatatoServer_Click()
Dim fPath As String
'
'truncate table [MonikaDB].[dbo].[tblMaster]
'truncate table [MonikaDB].[dbo].[tblHRIS]
'truncate table [MonikaDB].[dbo].[tblCombined]

fPath1 = shtAdmin.[C46] & "\"
fPath = "D:\6. HRIS\HRIS_Monika Group\"

Debug.Print "Start Time  - " & Now()
lblWorkingStatus.Caption = " Working on tblMaster"
Call ImportDataFromExcelToSQLServer(fPath1 & "WP MasterData.xlsx", "Master Data_Work Processes$", "tblMaster")
lblWorkingStatus.Caption = "Working on tblHRIS"
Call ImportDataFromExcelToSQLServer(fPath & "1 HRIS_ Monika Alcobev.xlsx", "Monika Alcobev HRIS$", "tblHRIS") 'Monika Alcobev HRIS$
lblWorkingStatus.Caption = "Working on tblWorkProcess"
Call ImportDataFromExcelToSQLServer(fPath1 & "Work Process.xlsx", "WorkProcess$", "tblWorkProcess")
lblWorkingStatus.Caption = "Updating Combined  data table."
Call UpdateCombinedData
Debug.Print "End Time  - " & Now()
lblWorkingStatus.Caption = "Data Loaded Sucessfully !!!"
lblWorkingStatus.BackColor = 8454016
End Sub
Function ImportDataFromExcelToSQLServer(xlFilePath As String, xlSheetName As String, Optional sqlTableName As String, Optional delolddata As Boolean)
'Function ImportDataFromExcelToSQLServer()
    Dim xlCn As Object
    Dim xlRs As Object
    Dim cmd As Object
    Dim connectionString As String
    Dim tableName As String
    Dim columnNames As String
    Dim rowValues As String
    Dim batchSize As Integer
    Dim lastCol As Integer
    Dim lastRow As Long
    Dim rCount As Integer
    Dim eRow As Integer
    
       
    ' Define Connection String for Excel
    'connectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & xlFilePath & ";Extended Properties='Excel 12.0 Xml;HDR=YES';"
    connectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & xlFilePath & ";Extended Properties='Excel 12.0 Xml;HDR=YES';"
    
    ' Initialize ADODB Objects
    Set xlCn = CreateObject("ADODB.Connection")
    Set xlRs = CreateObject("ADODB.Recordset")
    xlCn.Open connectionString
    
    ' Retrieve Data from Excel
    sqlQuery = "SELECT * FROM [" & xlSheetName & "]"
    If sqlTableName = "" Then sqlTableName = xlSheetName  ' Memory free to use xlsheetname
    xlRs.Open sqlQuery, xlCn, 1, 1 ' adOpenKeyset and adLockReadOnly
    
    If xlRs.EOF Then
        MsgBox "No data found in the Excel file!", vbExclamation
        GoTo endFunction
    End If


    ' Initialize batch processing
    batchSize = 100
    lastCol = xlRs.Fields.Count - 1
    lastRow = xlRs.recordcount
    rCount = 1
    eRow = 0
'    tableName = "tblMaster"

    xlRs.MoveFirst

    'Open SQL Server Connection
    If cnopen(1) = False Then GoTo endFunction
    
    
'    sqlQuery = "Select * from '" & sqlTableName & "' "
'    If rsOpen(1) = False Then GoTo endFunction
'    If rs.recordCount > 1 Then
    sqlQuery = " SP_TruncateTable " & sqlTableName & " "
    If rsOpen(4) = False Then GoTo endFunction
    
    Set cmd = CreateObject("ADODB.Command")
    cmd.ActiveConnection = cn

    'Loop through the Excel data and insert in batches
    Do While Not xlRs.EOF
        DoEvents
        eRow = Application.Min(rCount + batchSize - 1, lastRow)
        sqlQuery = "INSERT INTO " & sqlTableName & " ("

        'Build Column Names
        For j = 0 To lastCol
            sqlQuery = sqlQuery & "[" & xlRs.Fields(j).Name & "]"
            If j < lastCol Then sqlQuery = sqlQuery & ", "
        Next
        sqlQuery = sqlQuery & ") VALUES "

        'Build Row Values
        For i = rCount To eRow
            DoEvents
            rowValues = "("
            For j = 0 To lastCol
                DoEvents
                If j > lastCol Then ' Just breaker only
                    GoTo endFunction
                End If
                On Error Resume Next
'                Debug.Print xlRs.Fields(j).value
                If IsNull(xlRs.Fields(j).value) Then
                    If IsNull(xlRs.Fields("EMployee_Name").value) Then
                         xlRs.MoveNext
                         If IsNull(xlRs.Fields("EMployee_Name").value) Then
                            GoTo endFunction
                         End If
                    End If
                    rowValues = rowValues & "NULL"
                ElseIf TypeName(xlRs.Fields(j).value) = "Error" Then
                    rowValues = rowValues & "NULL"
                Else
                 rowValues = rowValues & "'" & Replace(xlRs.Fields(j).value, "'", "''") & "'"
                End If
            
                On Error GoTo 0
                If j < lastCol Then rowValues = rowValues & ","
         
            Next
            rowValues = rowValues & "),"
            sqlQuery = sqlQuery & rowValues
            xlRs.MoveNext
            rCount = rCount + 1
           
        Next
        sqlQuery = Left(sqlQuery, Len(sqlQuery) - 1) & ";"
        Debug.Print sqlQuery
        cmd.CommandText = sqlQuery
        cmd.CommandType = 1
        cmd.Execute
    Loop

endFunction:
    On Error Resume Next
    xlRs.Close
    xlCn.Close
    Set xlRs = Nothing
    Set xlCn = Nothing
    rsclose
    cnclose
End Function

Loading

]]>
Import Data From Closed Excel File To SERVER https://www.excelmacroclasses.com/import-data-from-closed-excel-file-to-server/ Wed, 29 Jan 2025 08:51:37 +0000 https://www.excelmacroclasses.com/?p=280
Sub ImportDataFromClosedExcelToSQLServer()
    Dim xlCn As Object, xlRs As Object
    Dim xlFilePath As String, tableName As String, connectionString As String
    'Dim columnNames As String, rowValues As String
    Dim batchSize As Long, lastRow As Long, rCount As Long, eRow As Long
    Dim i As Long, j As Long, lastCol As Long, tableExists As Boolean

    Debug.Print "Start Time: " & Now()

    ' File path and table name configuration
    xlFilePath = "C:\Users\Rushikesh Badne\Downloads\Employee Sample Data.xlsx" ' Update as needed
    tableName = "Data"
    connectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                       "Data Source=" & xlFilePath & ";" & _
                       "Extended Properties='Excel 12.0 Xml;HDR=YES';"
                       
      Set xlCn = CreateObject("ADODB.Connection")
      Set xlRs = CreateObject("ADODB.Recordset")
      xlCn.Open connectionString
      
       sqlQuery = "SELECT * FROM [Data$]"
      xlRs.Open sqlQuery, xlCn, 1, 1
    
    lastCol = xlRs.Fields.Count - 1
    lastRow = xlRs.recordCount
'      ' Check data availability in Excel
'       If xlRs.EOF Then
'          MsgBox "No data found in the Excel file!", vbExclamation
'          GoTo CleanUp
'       End If

    ' Check table existence in SQL Server
    sqlQuery = "SELECT 1 FROM INFORMATION_SCHEMA.TABLES WHERE TABLE_NAME = '" & tableName & "'"
    Debug.Print sqlQuery
    If cnopen(1) = False Then GoTo CleanUp
    If rsOpen() = False Then GoTo CleanUp


    'On Error Resume Next
    If rs.recordCount >= 1 Then
        tableExists = True
    Else
        tableExists = False
    End If
'    On Error GoTo 0

   If tableExists Then
        sqlQuery = "DELETE FROM " & tableName
        If rsOpen(2) = False Then GoTo CleanUp
       
    Else
       ' Create header based on Excel table Header and create table
        sqlQuery = "CREATE TABLE " & tableName & "("
        For j = 0 To xlRs.Fields.Count - 1
            sqlQuery = sqlQuery & "[" & xlRs.Fields(j).Name & "] NVARCHAR(255)"
            If j < xlRs.Fields.Count - 1 Then sqlQuery = sqlQuery & ", "
            Debug.Print sqlQuery
        Next j
        sqlQuery = sqlQuery & ");"
        If rsOpen(2) = False Then GoTo CleanUp
        MsgBox tableName & " table created successfully!"
    End If

 ' Import data to SQL Server
 '  Set BatchSize how much record in 1 batch to insert in table.
    batchSize = 2 '1000
    rCount = 1

    xlRs.MoveFirst
    Do While rCount <= lastRow
        DoEvents
        eRow = Application.Min(rCount + batchSize - 1, lastRow)
        sqlQuery = "INSERT INTO " & tableName & " ("

         'Add column names
        For j = 0 To lastCol
            sqlQuery = sqlQuery & "[" & xlRs.Fields(j).Name & "]"
            If j < lastCol Then sqlQuery = sqlQuery & ", "
        Next
        sqlQuery = sqlQuery & ") VALUES "

        ' Add row values
        For i = rCount To eRow
            DoEvents
            rowValues = "("
            For j = 0 To lastCol
                rowValues = rowValues & "'" & xlRs.Fields(j).Value & "'"
                If j < lastCol Then rowValues = rowValues & ", "
            Next
            rowValues = rowValues & "),"
            sqlQuery = sqlQuery & rowValues
            xlRs.MoveNext
            rCount = rCount + 1
            Debug.Print sqlQuery
        Next
        sqlQuery = Left(sqlQuery, Len(sqlQuery) - 1) & ";"

        Debug.Print sqlQuery
        If rsOpen(2) = False Then GoTo CleanUp
    Loop
    
    Debug.Print sqlQuery
    MsgBox "Data added successfully!"

CleanUp:
    ' Close and clean up
    On Error Resume Next
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing
    xlRs.Close: Set xlRs = Nothing
    xlCn.Close: Set xlCn = Nothing
    Debug.Print "End Time: " & Now()
    Exit Sub

ErrorHandler:
    MsgBox "An error occurred: " & Err.Description, vbCritical
    Resume CleanUp
End Sub

Loading

]]>
Create Word File With Hierarchy Using Excel VBA https://www.excelmacroclasses.com/create-word-file-with-hierarchy-using-excel-vba/ Wed, 29 Jan 2025 08:40:44 +0000 https://www.excelmacroclasses.com/?p=277 Sub CreateWordFileWithHierarchy() Dim WordApp As Object Dim WordDoc As Object Dim WordRange As Object ' Create Word application and document objects On Error Resume Next Set WordApp = GetObject(, "Word.Application") If Err.Number <> 0 Then Set WordApp = CreateObject("Word.Application") Err.Clear End If On Error GoTo 0 WordApp.Visible = True Set WordDoc = WordApp.Documents.Add ' Sample data structure in Excel for headings and content ' Column A: Level (1 for Main Heading, 2 for Subheading, 3 for Bullet Points, etc.) ' Column B: Content Dim ws As Worksheet Dim lastRow As Long Dim i As Long Set ws = ThisWorkbook.Sheets(1) lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow Dim level As Integer Dim content As String level = ws.Cells(i, 1).Value content = ws.Cells(i, 2).Value If level = 1 Then ' Main Heading (Heading 1) Set WordRange = WordDoc.content WordRange.Collapse Direction:=0 WordRange.Text = content WordRange.Style = WordDoc.Styles("Title") WordRange.InsertParagraphAfter ElseIf level = 2 Then ' Main Heading (Heading 1) Set WordRange = WordDoc.content WordRange.Collapse Direction:=0 WordRange.Text = content WordRange.Style = WordDoc.Styles("Heading 1") WordRange.InsertParagraphAfter ElseIf level = 3 Then ' Subheading (Heading 2) Set WordRange = WordDoc.content WordRange.Collapse Direction:=0 WordRange.Text = content WordRange.Style = WordDoc.Styles("Heading 2") WordRange.InsertParagraphAfter ' ElseIf level = 4 Then ' 'Heading 3 ' Set WordRange = WordDoc.content ' WordRange.Collapse Direction:=0 ' WordRange.Text = content ' WordRange.Style = WordDoc.Styles("Heading 3") ' WordRange.ListFormat.ApplyBulletDefault ' WordRange.InsertParagraphAfter ' ElseIf level = 5 Then ' ' Bullet Points ' Set WordRange = WordDoc.content ' WordRange.Collapse Direction:=0 ' WordRange.Text = content ' WordRange.Style = WordDoc.Styles("Normal") ' WordRange.ListFormat.ApplyBulletDefault ' WordRange.InsertParagraphAfter ' ' ' ElseIf level = 6 Then ' ' Bullet Points ' Set WordRange = WordDoc.content ' WordRange.Collapse Direction:=0 ' WordRange.Text = content ' WordRange.Style = WordDoc.Styles("List Paragraph") ' WordRange.ListFormat.ApplyBulletDefault ' WordRange.InsertParagraphAfter ' End If Next i ' Save and close the document Dim savePath As String ' savePath = Application.DefaultFilePath & "\HierarchyDocument.docx" ' WordDoc.SaveAs2 savePath MsgBox "Document created and saved at: " & savePath, vbInformation ' Cleanup Set WordRange = Nothing Set WordDoc = Nothing Set WordApp = Nothing End Sub

Loading

]]>