Posts by fredlo2010

Option Explicit
Sub TestOpenDoc()    'Open new document based on SOA template


    Dim wdApp As Object
    Dim wdDoc As Object
    Dim SaveName As String
    Dim FileExt As String


    ' Set the variables
    Set wdApp = CreateObject("Word.Application")


    ' Check that the excel object was created
    If Not wdApp Is Nothing Then


        ' Open new word document using existing template.
        wdApp.Visible = True
        wdApp.Activate
        
        Set wdDoc = wdApp.Documents.Add("H:\KiwiSaver\SOA\AdviceCheck_Kiwisaver SOA 11March 2015 testv2.dotx", , , True)


        'Check which version of word user is using before saving file extension
        If wdApp.Version < 11 Then
            FileExt = ".doc"
        Else
            FileExt = ".docx"
        End If


        'Cover letter and Page 1 SOA
        With wdDoc
            '     'Cover letter and Page 1 SOA
            If .Bookmarks.Exists("ADD1") Then
                .Bookmarks("ADD1").Range.Text = TextBox4.Value    'addr line1
            End If
            '      If .Bookmarks.Exists("Add2") Then
            '      .Bookmarks("Add2").Range.Text = TextBox5.Value 'addr line2
            '        ' .Bookmarks("Add2").Range.Text = "Hastings"
            '      End If
            '      If .Bookmarks.Exists("Add3") Then
            '         .Bookmarks("Add3").Range.Text = TextBox6.Value 'addr line3
            '         '.Bookmarks("Add3").Range.Text = "Hawkes Bay" 'addr line3
            '      End If


            ' Create the file name and save
            SaveName = Environ("userprofile") & "\Desktop\" & frmPersonalData.TextBox2 & ", " & frmPersonalData.TextBox1 & " KiwiSaverSOA " & Format(Date, "dd mmm yyyy") & FileExt


            .SaveAs2 SaveName
        End With


        ' Inform the user
        Beep
        MsgBox "Data successfully transferred. File has been saved."
    Else
        MsgBox "There was a problem opening Word.", vbCritical
    End If


    ' Clean up
    Unload frmPersonalData
    Set wdApp = Nothing


End Sub

Sub GroupUngroup()    
    Dim rArea As Range
    Dim rAreaSub As Range
    Dim lRow As Long
    Dim i As Long
    
    ' Clear previous outlines
    Cells.ClearOutline
    
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    ' Loop through the values.
    For i = 1 To lRow
               
        If Cells(i, 1).Value = "Area" Then
            Set rArea = Cells(i, 1).Offset(1)
        ElseIf Cells(i, 1).Value = "Area Sub" Then
            Set rAreaSub = Cells(i, 1).Offset(-1)
        End If
        
        If Not rArea Is Nothing And Not rAreaSub Is Nothing Then
            ' Create the outlines
            Range(rArea, rAreaSub).Rows.Group
            
            ' Reset the variables
            Set rArea = Nothing
            Set rAreaSub = Nothing
        End If
    Next i    
    
End Sub

Function GetRecordSet(oConn As Object, ByVal strSQLCommand) As Object


    Dim oRecordSet As Object
    Dim oCmd As Object
    Dim i As Long
    
    On Error GoTo Error_Handler
    
    Set oCmd = CreateObject("ADODB.Command")
    Set oRecordSet = CreateObject("ADODB.Recordset")
    
    With oCmd
        Set .ActiveConnection = oConn
        .CommandType = 1
        .CommandText = strSQLCommand




        Set oRecordSet = .Execute(, , 16)
    End With
    
    ' Loop to inform the user that we are getting the data.
    Do
        i = 0
        Application.StatusBar = "Getting data .......... " & String(CInt(i \ 10), "|")
        i = i + 1
    Loop While oRecordSet Is Nothing
    
    
    
Exit_Handler:
    
    If oRecordSet.State = 1 Then
        Set GetRecordSet = oRecordSet
    Else
        Set GetRecordSet = Nothing
    End If
    
    On Error GoTo 0
    
    ' Clean up
    Set oRecordSet = Nothing
    Set oCmd = Nothing








    Exit Function
    
Error_Handler:




    MsgBox "Error in: " & ThisWorkbook.VBProject.VBE.ActiveCodePane.CodeModule & vbCr & _
           Err.Description, vbCritical
    
    Resume Exit_Handler




End Function

Option Explicit




Sub TransposeData()
    
    ' First we need to declare the variables.
    Dim wbTarget As Workbook
    Dim wbOrigen As Workbook
    
    Dim shTarget As Worksheet
    Dim shOrigen As Worksheet
    
    ' Now lets set the variables to the workbooks.
    ' Make sure that both workbooks are open; for now
    ' in the future you can open them as you need.
    Set wbTarget = Workbooks("My Target Workbook.xlsm")
    Set wbOrigen = Workbooks("D35 December 14.xlsx")
    
    ' Now we will asign the reference to the sheets.
    ' note that I am using thr workbooks I asigned to
    ' variables before.
    Set shTarget = wbTarget.Worksheets("Gas Balancing")
    Set shOrigen = wbOrigen.Worksheets("PAGE 01")
    
    
    ' Now that we have our variables set (Most likly the
    ' reason of your subscript out of range error) lets
    ' copy the range.
    shOrigen.Range("R77:R80").Copy
    shTarget.Range("B4").PasteSpecial Transpose:=True
    
    
    ' Now we clear our clip board.
    Application.CutCopyMode = False
    
    ' Now we destroy all the objects we created.
    Set shOrigen = Nothing
    Set shTarget = Nothing
    Set wbTarget = Nothing
    Set wbOrigen = Nothing    
    
End Sub

Option Explicit




Sub Test()




    Dim SC As String, i As Integer, a As Range, JobList As Worksheet, ContractReport As Worksheet
    Set JobList = Sheets("JobList")
    Set ContractReport = Sheets("ContractReport")
    SC = "Sales Commission"




    With ContractReport
        For Each a In JobList.Range("Table2[Task/Activity]").SpecialCells(xlCellTypeVisible)
            If a.Value = SC Then
                For i = 8 To 13
                    If .Cells(i, b).Value = "" Then
                        .Cells(i, b).Value = a.Offset(0, -4).Value
                        .Cells(i, c).Value = a.Offset(0, -1).Value
                    End If
                Next i
            End If
        Next a
    End With
    
End Sub

Sub Test()
        
    ' Have you tried these?
    ActiveCell.Value = CDate(DateBox & " " & TimeBox)
    
    ' OR
    ' I think this one will be better.
    ActiveCell.Value = DateValue(DateBox & " " & TimeBox)
    
   
   ' Make sure that the destination range is formatter as date.
   ActiveCell.NumberFormat = "DD/MM/YYYY HH:MM:SS"
    
    ' Unload the form.
    Unload Me




End Sub

Option Explicit




Sub Macro1()


    Dim oQuery As QueryTable
    Dim strConnection As String
    Dim strSQL As String
    Dim i As Long




    strSQL = "SELECT * " & _
             "FROM FactSales " & _
             "WHERE FactSales.channelKey=2 " & _
             "AND FactSales.PromotionKey=1;"


    strConnection = "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=C:\Users\Alfred\Downloads\ContosoV2\ContosoSales.accdb"




    Set oQuery = ActiveSheet.QueryTables.Add(strConnection, ActiveSheet.Range("A1"))


    With oQuery
        .CommandType = xlCmdSql
        .CommandText = strSQL
        .PreserveFormatting = True
        .BackgroundQuery = True
        .SavePassword = False
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .Refresh BackgroundQuery:=True
    End With
    
    ' Wait for the query to finish.
    Do
        If Not i = 100 Then
            i = i + 1
            DoEvents
            Application.StatusBar = "Getting Query ............. " & String$(i / 2, "|")
        Else
            i = 0
        End If
    Loop While oQuery.Refreshing




    ' Remove the query and reset the bar.
    oQuery.Delete
    Application.StatusBar = False
    
    ' Clean up
    Set oQuery = Nothing    
    
End Sub