Snasui Excel Forum

Code: Select all

Private Sub CommandButton2_Click()
Dim sb As Workbook
Dim sh As Worksheet
Dim rngA As Range
Dim r As Range
Dim strSb As String
Dim Ref As String
Dim f As Boolean
strSb = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
Set sb = Workbooks.Open(Filename:=strSb, UpdateLinks:=False, ReadOnly:=True)
f = False
With ThisWorkbook.Worksheets("Input")
    Ref = .Range("F6").Value
    For Each sh In sb.Worksheets
        Set rngA = sh.Range("a2", sh.Range("a" & sh.Rows.Count).End(xlUp))
        For Each r In rngA
            If r.Value = Ref Then
                .Range("C10").Value = r.Offset(0, 6).Value
                .Range("F10").Value = r.Offset(0, 5).Value
                .Range("C12").Value = r.Offset(0, 7).Value
                .Range("C14").Value = r.Offset(0, 12).Value
                 .Range("C16").Value = r.Offset(0, 11).Value
                 .Range("C18").Value = r.Offset(0, 16).Value
                .Range("C20").Value = r.Offset(0, 20).Value
                .Range("C22").Value = r.Offset(0, 22).Value
                .Range("E22").Value = r.Offset(0, 23).Value
                f = True
                Exit For
            End If
        Next r
        If f Then Exit For
    Next sh
End With
sb.Close False
End Sub

Code: Select all

 
Private Sub CommandButton1_Click()

Dim sb As Workbook
Dim sh As Worksheet
Dim rngA As Range
Dim r As Range
Dim strSb As String
Dim Ref As String
Dim f As Boolean
strSb = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
Set sb = Workbooks.Open(Filename:=strSb, UpdateLinks:=False, ReadOnly:=False)
f = False

'Other code
Dim i As Long, j As Long
Dim arr(0, 26) As Variant
Me.ListBox1.Clear
Me.ListBox1.AddItem
For a = 0 To 26
    arr(0, a) = sh.Cells(1, a + 1).Value
'    Me.ListBox1.List(0, a - 1) = Sheet1.Cells(1, a)
Next a
Me.ListBox1.ColumnCount = 26
Me.ListBox1.List = arr
'Me.ListBox1.Locked = True
ListBox1.ColumnWidths = "25 ,0 ,0 ,0,0 ,64 ,0 ,68 ,60,25, 25,70 ,70 ,0 ,0 ,0 ,0,80,0 ,0 ,0 ,0 ,0 ,0 ,0, 50"
ListBox1.Height = 170
ListBox1.Width = 550
ListBox1.Left = 764
ListBox1.Top = 282
'Other code
    'For List Box fill
    'For i = 2 To Sheet4.Range("A1000000").End(xlUp).Row
   
     For i = sh.Range("A1000000").End(xlUp).Row To 2 Step -1
        If sb.Cells(i, 7).Value = TextBox1.Value Then
            Me.ListBox1.AddItem
            For x = 1 To 26
                Me.ListBox1.List(ListBox1.ListCount - 1, x - 1) = sh.Cells(i, x)
            Next x
        End If
    Next i

Code: Select all

Private Sub CommandButton1_Click()

    Dim sb As Workbook
    Dim sh As Worksheet
    Dim rngA As Range
    Dim r As Range
    Dim strSb As String
    Dim Ref As String
    Dim f As Boolean
    strSb = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
    Set sb = Workbooks.Open(Filename:=strSb, UpdateLinks:=False, ReadOnly:=False)
    Set sh = sb.Worksheets("Data")
    f = False
    
    'Other code
    Dim i As Long, j As Long
    Dim b As Variant
    Dim arr(0, 26) As Variant
    Me.ListBox1.Clear
    Me.ListBox1.AddItem
    
    ReDim b(sh.Range("A1000000").End(xlUp).Row, 26)
    'For i = sh.Range("A1000000").End(xlUp).Row To 2 Step -1
    For i = 0 To UBound(b)
        For a = 0 To 26
            b(i, a) = sh.Cells(i + 2, a + 1).Value
            Debug.Print sh.Cells(i + 2, a + 1).Address
        '    Me.ListBox1.List(0, a - 1) = Sheet1.Cells(1, a)
        Next a
    Next i
    Me.ListBox1.ColumnCount = 26
    Me.ListBox1.List = b
    'Me.ListBox1.Locked = True
    ListBox1.ColumnWidths = "25 ,0 ,0 ,0,0 ,64 ,0 ,68 ,60,25, 25,70 ,70 ,0 ,0 ,0 ,0,80,0 ,0 ,0 ,0 ,0 ,0 ,0, 50"
    ListBox1.Height = 170
    ListBox1.Width = 550
    ListBox1.Left = 764
    ListBox1.Top = 282
    'Other code
        'For List Box fill
        'For i = 2 To Sheet4.Range("A1000000").End(xlUp).Row
       
    '        If sb.Cells(i, 7).Value = TextBox1.Value Then
    '            Me.ListBox1.AddItem
    '            For x = 1 To 26
    '                Me.ListBox1.List(ListBox1.ListCount - 1, x - 1) = sh.Cells(i, x)
    '            Next x
    '        End If

End Sub

Code: Select all

Sub sample2()

    Dim FileSystem As Object
    Dim HostFolder As String

    HostFolder = "\\10.21.4.97\File Sharing2\DataPricing\"
    
    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder2 FileSystem.GetFolder(HostFolder)
    
End Sub


Sub DoFolder2(Folder)
    Dim SubFolder
    Dim File
    Dim n As Long
    Dim n2 As Long
    Dim sh As Worksheet
    Dim tws As Workbook
    
    Dim i As Long, j As Long
    Dim b As Variant
    Dim arr(0, 26) As Variant
      
    For Each File In Folder.Files
        If File.Name = "All Data Estimated" Then
    ListBox1.Clear
   ListBox1.AddItem
    
    ReDim b(sh.Range("A1000000").End(xlUp).Row, 26)
    For i = 0 To UBound(b)
        For a = 0 To 26
            b(i, a) = sh.Cells(i + 2, a + 1).Value
            Debug.Print sh.Cells(i + 2, a + 1).Address
        Next a
    Next i
    
            Call GetSheetname(theFullName:=File)
        End If
    Next
End Sub

Sub ImportFile(sFile As String, sh As String)
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    On Error Resume Next
    shtName = "[" & VBA.Replace(sh, "'", "") & "]"
    sql = "select * from " & shtName
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    With Worksheets("data")
        .Range("A" & Rows.Count).End(xlUp).Offset(1, 0) _
            .CopyFromRecordset rs
    End With
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub


Function GetSheetname(ByVal theFullName As String) As String
    Dim cn As ADODB.Connection
    Dim rsT As ADODB.Recordset
    Dim intTblCnt As Integer
    Dim strTbl As String
    Dim t As Integer
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
      '  & "Data Source=" & theFullName & ";" _
      '  & "Extended Properties=""Excel 12.0 Xml;HDR=NO"";"

    Set rsT = cn.OpenSchema(adSchemaTables)
    intTblCnt = rsT.RecordCount

    Do While Not rsT.EOF
        strTbl = rsT.Fields("TABLE_NAME").Value
        If Right(strTbl, 2) = "$'" And VBA.Left(strTbl, 11) = "'COST SHEET" Then
           Call ImportFile(sFile:=theFullName, sh:=strTbl)
        End If
        rsT.MoveNext
    Loop
    rsT.Close
    cn.Close
End Function

Code: Select all

Sub ImportData()
    Dim sFile As String, sh As Worksheet
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    Dim arr() As Variant, i As Integer, j As Integer
    sFile = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
    shtName = "[Data$]"
    sql = "select * from " & shtName
    sCnstr.CursorLocation = adUseClient
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    With Worksheets("input")
        .ListBox1.Clear
        .ListBox1.AddItem
        ReDim arr(rs.RecordCount, 26)
        Do While Not rs.EOF
            For i = 0 To 26
                arr(j, i) = rs.Fields(i).Value
            Next i
            j = j + 1
            rs.MoveNext
        Loop
        .ListBox1.List = arr
    End With
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub

Code: Select all

Sub SaveData()

ColName = 6
 ColHN = 7
ColDOB = 8
ColPayer = 9
ColNation = 10

    Dim sFile As String, sh As Worksheet
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    Dim arr() As Variant, i As Integer, j As Integer
    Dim WI As Worksheet
    
    sFile = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
    shtName = "[Data$]"
    sql = "select * from " & shtName
    sCnstr.CursorLocation = adUseClient
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    
    Set WI = Worksheets("Input")
    Set WD = rs.Worksheets("Data")
    
    'Find the next empty row
    Dim lastrow As Long
    Dim NewRow As Long
    Dim LastRowDate As Long
    Dim NewRowDate As Long
    
    lastrow = WD.Range("A1000000").End(xlUp).Row
    NewRow = lastrow + 1
    
'Create reference number
    WD.Cells(NewRow, 2).Value = Day(Date)
    WD.Cells(NewRow, 3).Value = Month(Date)
    WD.Cells(NewRow, 4).Value = Year(Date) - 2000
    
    
    'Reference number reset to 1 on new date
    LastRowDate = WD.Cells(lastrow, 2).Value
    NewRowDate = WD.Cells(NewRow, 2).Value
    If LastRowDate <> NewRowDate Then
        WD.Cells(NewRow, 5).Value = 1
    Else
        WD.Cells(NewRow, 5).Value = WD.Cells(lastrow, 5) + 1
    End If
    
  
    'Format month, date, and reference number
    WD.Cells(NewRow, 3).NumberFormat = "00"
    WD.Cells(NewRow, 2).NumberFormat = "00"
    WD.Cells(NewRow, 5).NumberFormat = "0000"

    'Assign unique reference number in column 1
    RefNo = WD.Cells(NewRow, 4).Text & "-" & WD.Cells(NewRow, 3).Text & "-" & WD.Cells(NewRow, 2).Text & "-" & WD.Cells(NewRow, 5).Text
    WD.Cells(NewRow, 1).Value = RefNo
    
    
    'Assign RefNo back to Input page
    WI.Range("InputRefNo") = RefNo
    
    'Assign Date/Time
    WI.Range("InputEstimateDateTime") = Now
    
         WD.Cells(NewRow, ColName).Value = WI.Range("InputName")
    WD.Cells(NewRow, ColHN).Value = WI.Range("InputHN")
    WD.Cells(NewRow, ColDOB).Value = WI.Range("InputDOB")
    WD.Cells(NewRow, ColPayer).Value = WI.Range("InputPayer")
    WD.Cells(NewRow, ColNation).Value = WI.Range("InputNation")
    
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub

Code: Select all

Sub ImportData()
    Dim sFile As String, sh As Worksheet
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    Dim arr() As Variant, i As Integer, j As Integer
    sFile = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
    shtName = "[Data$]"
    sql = "select * from " & shtName
    sCnstr.CursorLocation = adUseClient
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    With Worksheets("input")
     If rs.Cells(i, 7).Value = Sheet1.Cells(3, 15).Value Then
        .ListBox1.Clear
        .ListBox1.AddItem
        ReDim arr(rs.RecordCount, 26)
        Do While Not rs.EOF
            For i = 0 To 26
                arr(j, i) = rs.Fields(i).Value
            Next i
            j = j + 1
            rs.MoveNext
        Loop
        .ListBox1.List = arr
    End With
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub

Code: Select all

'--------other code------------
    With Worksheets("input")
     If rs.Fields(7).Value = Sheet1.Cells(3, 15).Value Then
        .ListBox1.Clear
        .ListBox1.AddItem
        ReDim arr(rs.RecordCount, 26)
        Do While Not rs.EOF
            For i = 0 To 26
                arr(j, i) = rs.Fields(i).Value
            Next i
            j = j + 1
            rs.MoveNext
        Loop
        .ListBox1.List = arr
          End If
    End With

Code: Select all

Sub ImportData()
    Dim sFile As String, sh As Worksheet
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    Dim arr() As Variant, i As Integer, j As Integer
    Dim strS As String
    
    strS = Sheets(1).OLEObjects("TextBox1").Object.Text
    sFile = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
    shtName = "[Data$]"
    sql = "select * from " & shtName
    sCnstr.CursorLocation = adUseClient
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    With Worksheets("input")
'     If rs.Fields(7).Value = Sheet1.Cells(3, 15).Value Then
        .ListBox1.Clear
        .ListBox1.AddItem
        ReDim arr(rs.RecordCount, 26)
        Do While Not rs.EOF
            If rs.Fields(6).Value = "HN" Or rs.Fields(6).Value = strS Then
                For i = 0 To 26
                    arr(j, i) = rs.Fields(i).Value
                Next i
            End If
            j = j + 1
            rs.MoveNext
        Loop
        .ListBox1.List = arr
'          End If
    End With
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub

Code: Select all

           If rs.Fields(6).Value = "HN" Or rs.Fields(6).Value = strS Then
                For i = 0 To 26
                    arr(j, i) = rs.Fields(i).Value
                    
                  If arr(j, i) = "" Then
                  arr(j, i).EntireRow.Delete
                  End If
                  
                Next i
            End If
            j = j + 1
            rs.MoveNext

Code: Select all

Sub SaveData()

ColName = 6
 ColHN = 7
ColDOB = 8
ColPayer = 9
ColNation = 10

    Dim sFile As String, sh As Worksheet
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    Dim arr() As Variant, i As Integer, j As Integer
    Dim WI As Worksheet
    
    sFile = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
    shtName = "[Data$]"
    sql = "select * from " & shtName
    sCnstr.CursorLocation = adUseClient
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    
    Set WI = Worksheets("Input")
    Set WD = rs.Worksheets("Data")
    
    'Find the next empty row
    Dim lastrow As Long
    Dim NewRow As Long
    Dim LastRowDate As Long
    Dim NewRowDate As Long
    
    lastrow = WD.Range("A1000000").End(xlUp).Row
    NewRow = lastrow + 1
    
'Create reference number
    WD.Cells(NewRow, 2).Value = Day(Date)
    WD.Cells(NewRow, 3).Value = Month(Date)
    WD.Cells(NewRow, 4).Value = Year(Date) - 2000
    
    
    'Reference number reset to 1 on new date
    LastRowDate = WD.Cells(lastrow, 2).Value
    NewRowDate = WD.Cells(NewRow, 2).Value
    If LastRowDate <> NewRowDate Then
        WD.Cells(NewRow, 5).Value = 1
    Else
        WD.Cells(NewRow, 5).Value = WD.Cells(lastrow, 5) + 1
    End If
    
  
    'Format month, date, and reference number
    WD.Cells(NewRow, 3).NumberFormat = "00"
    WD.Cells(NewRow, 2).NumberFormat = "00"
    WD.Cells(NewRow, 5).NumberFormat = "0000"

    'Assign unique reference number in column 1
    RefNo = WD.Cells(NewRow, 4).Text & "-" & WD.Cells(NewRow, 3).Text & "-" & WD.Cells(NewRow, 2).Text & "-" & WD.Cells(NewRow, 5).Text
    WD.Cells(NewRow, 1).Value = RefNo
    
    
    'Assign RefNo back to Input page
    WI.Range("InputRefNo") = RefNo
    
    'Assign Date/Time
    WI.Range("InputEstimateDateTime") = Now
    
         WD.Cells(NewRow, ColName).Value = WI.Range("InputName")
    WD.Cells(NewRow, ColHN).Value = WI.Range("InputHN")
    WD.Cells(NewRow, ColDOB).Value = WI.Range("InputDOB")
    WD.Cells(NewRow, ColPayer).Value = WI.Range("InputPayer")
    WD.Cells(NewRow, ColNation).Value = WI.Range("InputNation")
    
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub

Code: Select all

Sub SaveData()

ColName = 6
 ColHN = 7
ColDOB = 8
ColPayer = 9
ColNation = 10

    Dim sFile As String, sh As Worksheet
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    Dim arr() As Variant, i As Integer, j As Integer
    Dim WI As Worksheet
    
    sFile = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
    shtName = "[Data$]"
    sql = "insert into " & shtName
    sCnstr.CursorLocation = adUseClient
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    
    Set WI = Worksheets("Input")
    Set WD = rs.Worksheets("Data")
    
    'Find the next empty row
    Dim lastrow As Long
    Dim NewRow As Long
    Dim LastRowDate As Long
    Dim NewRowDate As Long
    
    lastrow = WD.Range("A1000000").End(xlUp).Row
    NewRow = lastrow + 1
    
'Create reference number
    WD.Cells(NewRow, 2).Value = Day(Date)
    WD.Cells(NewRow, 3).Value = Month(Date)
    WD.Cells(NewRow, 4).Value = Year(Date) - 2000
    
    
    'Reference number reset to 1 on new date
    LastRowDate = WD.Cells(lastrow, 2).Value
    NewRowDate = WD.Cells(NewRow, 2).Value
    If LastRowDate <> NewRowDate Then
        WD.Cells(NewRow, 5).Value = 1
    Else
        WD.Cells(NewRow, 5).Value = WD.Cells(lastrow, 5) + 1
    End If
    
  
    'Format month, date, and reference number
    WD.Cells(NewRow, 3).NumberFormat = "00"
    WD.Cells(NewRow, 2).NumberFormat = "00"
    WD.Cells(NewRow, 5).NumberFormat = "0000"

    'Assign unique reference number in column 1
    RefNo = WD.Cells(NewRow, 4).Text & "-" & WD.Cells(NewRow, 3).Text & "-" & WD.Cells(NewRow, 2).Text & "-" & WD.Cells(NewRow, 5).Text
    WD.Cells(NewRow, 1).Value = RefNo
    
    
    'Assign RefNo back to Input page
    WI.Range("InputRefNo") = RefNo
    
    'Assign Date/Time
    WI.Range("InputEstimateDateTime") = Now
    
         WD.Cells(NewRow, ColName).Value = WI.Range("InputName")
    WD.Cells(NewRow, ColHN).Value = WI.Range("InputHN")
    WD.Cells(NewRow, ColDOB).Value = WI.Range("InputDOB")
    WD.Cells(NewRow, ColPayer).Value = WI.Range("InputPayer")
    WD.Cells(NewRow, ColUsePackage).Value = WI.Range("InputUsePackage")
    WD.Cells(NewRow, ColNation).Value = WI.Range("InputNation")


    
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub

Code: Select all

Sub ImportData()
    Dim sFile As String, sh As Worksheet
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    Dim arr() As Variant, i As Integer, j As Integer, k As Integer
    Dim strS As String
    
    strS = Sheets(1).OLEObjects("TextBox1").Object.Text
    sFile = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"

    shtName = "[Data$]"
    sql = "select * from " & shtName & " Where HN ='" & strS & " ' Order By 'RefNo'"
    sCnstr.CursorLocation = adUseClient
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    With Worksheets("input")
        .ListBox1.Clear
        .ListBox1.AddItem
        ReDim arr(rs.RecordCount, 26)
        Do While Not rs.EOF
            For i = 0 To 26
                If j = 0 Then
                    For k = 0 To 26
                        arr(j, k) = rs.Fields(k).Name
                    Next k
                    j = j + 1
                End If
                arr(j, i) = rs.Fields(i).Value
            Next i
            j = j + 1
            rs.MoveNext
        Loop
        .ListBox1.List = arr
    End With
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub

Code: Select all

Sub SaveData()

ColName = 6
 ColHN = 7
ColDOB = 8
ColPayer = 9
ColNation = 10

    Dim sFile As String, sh As Worksheet
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    Dim arr() As Variant, i As Integer, j As Integer
    Dim WI As Worksheet
    
    sFile = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
    shtName = "[Data$]"
    sql = "insert  into  " & sFile
    sCnstr.CursorLocation = adUseClient
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    
    Set WI = Worksheets("Input")
    Set OW = Workbooks("All Data Estimated.xlsx")
    Set WD = OW.Worksheets("Data")
    
    'Find the next empty row
    Dim lastrow As Long
    Dim NewRow As Long
    Dim LastRowDate As Long
    Dim NewRowDate As Long
    
    lastrow = WD.Range("A1000000").End(xlUp).Row
    NewRow = lastrow + 1
    
'Create reference number
    WD.Cells(NewRow, 2).Value = Day(Date)
    WD.Cells(NewRow, 3).Value = Month(Date)
    WD.Cells(NewRow, 4).Value = Year(Date) - 2000
    
    
    'Reference number reset to 1 on new date
    LastRowDate = WD.Cells(lastrow, 2).Value
    NewRowDate = WD.Cells(NewRow, 2).Value
    If LastRowDate <> NewRowDate Then
        WD.Cells(NewRow, 5).Value = 1
    Else
        WD.Cells(NewRow, 5).Value = WD.Cells(lastrow, 5) + 1
    End If
    
  
    'Format month, date, and reference number
    WD.Cells(NewRow, 3).NumberFormat = "00"
    WD.Cells(NewRow, 2).NumberFormat = "00"
    WD.Cells(NewRow, 5).NumberFormat = "0000"

    'Assign unique reference number in column 1
    Refno = WD.Cells(NewRow, 4).Text & "-" & WD.Cells(NewRow, 3).Text & "-" & WD.Cells(NewRow, 2).Text & "-" & WD.Cells(NewRow, 5).Text
    WD.Cells(NewRow, 1).Value = Refno
    
    
    'Assign RefNo back to Input page
    WI.Range("InputRefNo") = Refno
    
    'Assign Date/Time
    WI.Range("InputEstimateDateTime") = Now
    
         WD.Cells(NewRow, ColName).Value = WI.Range("InputName")
    WD.Cells(NewRow, ColHN).Value = WI.Range("InputHN")
    WD.Cells(NewRow, ColDOB).Value = WI.Range("InputDOB")
    WD.Cells(NewRow, ColPayer).Value = WI.Range("InputPayer")
    WD.Cells(NewRow, ColUsePackage).Value = WI.Range("InputUsePackage")
    WD.Cells(NewRow, ColNation).Value = WI.Range("InputNation")
    
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub

Code: Select all

strSql = "INSERT INTO [Sheet1$]" & _
            " SELECT * FROM [Excel 12.0 Macro;HDR=Yes;" & _
            " Database=" & thisworkbook.fullname & ";Readonly=False].[Sheet1$I1:N4]"

Code: Select all

Sub SaveData()

    Dim sFile As String, sh As Worksheet
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    Dim arr() As Variant, i As Integer, j As Integer
    
    sFile = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
    shtName = "[Data$]"
    strSql = "INSERT INTO [Data$]" & _
            " SELECT * FROM [Excel 12.0 Macro;HDR=Yes;" & _
            " Database=" & ThisWorkbook.FullName & ";Readonly=False].[Sheet1$I1:N4]"

    sCnstr.CursorLocation = adUseClient
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub