VBA: Læs tilbage til database.

Prøv sådan her
Sub writeback()
Dim a As Range
Application.ScreenUpdating = False
Set a = [a1].CurrentRegion.Offset(1, 0).Resize([a1].CurrentRegion.Rows.Count - 1, [a1].CurrentRegion.Columns.Count)
a.Name = "data"

i = 1

For Each Row In [Data].Resize([Data].Rows.Count, 1)

    If i < [Data].Rows.Count + 1 Then
    Cells(1 + i, 1).Name = "Date"
    Cells(1 + i, 2).Name = "Dimension"
    Cells(1 + i, 3).Name = "Value"
    sql = "INSERT INTO test values('" & [Date] & "', '" & [Dimension] & "','" & [Value] & "')"
    Mssql2005_open (sql)

    End If
    i = i + 1
Next

Application.ScreenUpdating = True
End Sub

Det giver ingen effekt af slå skærm opdateringen fra. Er der ikke flere gode ideer?

Åbner og lukker du forbindelsen til databasen for hver gennemløb af løkken, eller holder du forbindelsen åben indtil alle 2000 records er sendt?

Mssql2005_open (sql). Er det en sub du selv har lavet til at kommunikere med databasen?

Ja, Connectionen er lavet således.

'connect to Mssql2005 (only needed if OUTPUT_TO_FILE=0)
Const Mssql2005_USER_NAME = "bjo_bi"              'login name
Const Mssql2005_PASSWORD = "bjo_bi"              'password
Const Mssql2005_SERVER = "SDSBQP1"         
Const MyODBCVersion = "SQL server" 
Const Mssql2005_database = "bjo_Bi"

Public Mssql2005_connection
Public Mssql2005_recordset

Function Mssql2005_connect()
   
    Set Mssql2005_connection = CreateObject("ADODB.Connection")
   
    Mssql2005_connection.ConnectionString = _
      "Driver=" & MyODBCVersion & ";" & _
      "UID=" & Mssql2005_USER_NAME & ";" & _
      "PWD=" & Mssql2005_PASSWORD & ";" & _
      "DataBase=" & Mssql2005_database & ";" & _
      "SERVER=" & Mssql2005_SERVER

    Mssql2005_connection.Open
       
End Function

Function Mssql2005_execute(sql)
   
    Call Mssql2005_connect
     
    Mssql2005_connection.Execute sql
   
End Function

Function Mssql2005_open(sql)
   
    Call Mssql2005_connect
   
    Set Mssql2005_recordset = CreateObject("ADODB.Recordset")
   
    Mssql2005_recordset.Open sql, Mssql2005_connection
   
End Function

Som jeg ser det, så åbner du 2000 gange til databasen, uden at lukke en eneste gang.

Følgende Function bliver slet ikke kalt i din kode? Bliver den brugt andet steds?
Function Mssql2005_execute(sql)
    Call Mssql2005_connect
    Mssql2005_connection.Execute sql
End Function


Ellers prøv med følgende.

Const Mssql2005_USER_NAME = "bjo_bi"
Const Mssql2005_PASSWORD = "bjo_bi"
Const Mssql2005_SERVER = "SDSBQP1"
Const MyODBCVersion = "SQL server"
Const Mssql2005_database = "bjo_Bi"

Public Mssql2005_connection
Public Mssql2005_recordset

Function Mssql2005_connect()
    Set Mssql2005_connection = CreateObject("ADODB.Connection")
    Mssql2005_connection.ConnectionString = _
      "Driver=" & MyODBCVersion & ";" & _
      "UID=" & Mssql2005_USER_NAME & ";" & _
      "PWD=" & Mssql2005_PASSWORD & ";" & _
      "DataBase=" & Mssql2005_database & ";" & _
      "SERVER=" & Mssql2005_SERVER
    Mssql2005_connection.Open
End Function

Sub writeback()
Dim a As Range
Set a = [a1].CurrentRegion.Offset(1, 0).Resize([a1].CurrentRegion.Rows.Count - 1, [a1].CurrentRegion.Columns.Count)
a.Name = "data"
i = 1
Call Mssql2005_connect
Set Mssql2005_recordset = CreateObject("ADODB.Recordset")
For Each Row In [Data].Resize([Data].Rows.Count, 1)
    If i < [Data].Rows.Count + 1 Then
      Cells(1 + i, 1).Name = "Date"
      Cells(1 + i, 2).Name = "Dimension"
      Cells(1 + i, 3).Name = "Value"
      sql = "INSERT INTO test values('" & [Date] & "', '" & [Dimension] & "','" & [Value] & "')"
      Mssql2005_recordset.Open sql, Mssql2005_connection
    End If
    i = i + 1
Next
Mssql2005_connection.Close
Set Mssql2005_recordset = Nothing
End Sub

Application.ScreenUpdating = False

Er kun brugbar når der skal ændres på noget af det synlige.

Den bliver dobbelt så langsom om at læse tilbage ved den nye kode. Men lukker den forbindelsen til databasen?

Er der ikke mulighed for at man kan samle data i Excel i et datasæt og læse det hele over på en gang, altså uden loop?

Nu har jeg ikke forstand på MsSql, men mere excel, jeg har rettet excel delen, så se om det hjælper

Sub writeback()
Dim Data As Variant
Data = [a1].CurrentRegion.Offset(1, 0).Resize([a1].CurrentRegion.Rows.Count - 1, [a1].CurrentRegion.Columns.Count)
For i = 1 To UBound(Data, 1)
    Sql = "INSERT INTO test values('" & Data(i, 1) & "', '" & Data(i, 2) & "','" & Data(i, 3) & "')"
    Mssql2005_open (Sql)
Next
End Sub

Smuk kode kabbak.

På 9.800 records var den oprindelige tid for upload 80 sekunder. Ved skift til koden fra kabbak er denne faldet til 55 sekunder. (fald ca. 25%)

Hvis der er flere gode ideer fra jeg eksperter modtages de gerne.

Det var åbentbart ikke det med at åbne og lukke der var det store problem.

Jeg tror du kan få det hurtigere endnu, hvis du kun åbner og lukker forbindelsen en gang.

Jeg har tilpasset koden med kabbaks tilpasninger.

Prøv det her.

Const Mssql2005_USER_NAME = "bjo_bi"
Const Mssql2005_PASSWORD = "bjo_bi"
Const Mssql2005_SERVER = "SDSBQP1"
Const MyODBCVersion = "SQL server"
Const Mssql2005_database = "bjo_Bi"

Public Mssql2005_connection
Public Mssql2005_recordset

Function Mssql2005_connect()
    Set Mssql2005_connection = CreateObject("ADODB.Connection")
    Mssql2005_connection.ConnectionString = _
      "Driver=" & MyODBCVersion & ";" & _
      "UID=" & Mssql2005_USER_NAME & ";" & _
      "PWD=" & Mssql2005_PASSWORD & ";" & _
      "DataBase=" & Mssql2005_database & ";" & _
      "SERVER=" & Mssql2005_SERVER
    Mssql2005_connection.Open
End Function

Sub writeback()
Dim Data As Variant
Call Mssql2005_connect ' Her åbner den forbindelsen
Set Mssql2005_recordset = CreateObject("ADODB.Recordset")
Data = [a1].CurrentRegion.Offset(1, 0).Resize([a1].CurrentRegion.Rows.Count - 1, [a1].CurrentRegion.Columns.Count)
For i = 1 To UBound(Data, 1)
    Sql = "INSERT INTO test values('" & Data(i, 1) & "', '" & Data(i, 2) & "','" & Data(i, 3) & "')"
    Mssql2005_open (Sql)
Next
Mssql2005_connection.Close ' Her lukker den forbindelsen
Set Mssql2005_recordset = Nothing
End Sub

5. nederste linje skal lige skiftes ud.

Mssql2005_open (Sql)
Skal skiftes ud med
Mssql2005_recordset.Open Sql, Mssql2005_connection

Så det ender med det her.
For i = 1 To UBound(Data, 1)
    Sql = "INSERT INTO test values('" & Data(i, 1) & "', '" & Data(i, 2) & "','" & Data(i, 3) & "')"
    Mssql2005_recordset.Open Sql, Mssql2005_connection
Next

Det gør faktisk kode langsommere, den var nu 120 sekunder om at uploade.

Jeg har prøvet med følgende:

Sub writeback2()
Dim Data As Variant
Data = [a1].CurrentRegion.Offset(1, 0).Resize([a1].CurrentRegion.Rows.Count - 1, [a1].CurrentRegion.Columns.Count)
For i = 1 To UBound(Data, 1)

If i = 1 Then
    sql = "INSERT INTO test SELECT '" & Data(i, 1) & "', '" & Data(i, 2) & "','" & Data(i, 3) & "'"
Else
    sql = sql + " UNION SELECT '" & Data(i, 1) & "', '" & Data(i, 2) & "','" & Data(i, 3) & "'"
End If
Next
    Mssql2005_open (sql)

End Sub


men problemet er and forbindelse til databasen lavet en TimeOut. Er der nogle der kan komme med noget input i forhold til denne løsning?

Jeg har tilpasset koden lidt.

Hvis du ved hvilket område dine data ligger i, tror jeg det er hurtigere bare at løbe det igennem, i stedet for at fylde en variabel med data før du sender.

Sql strengen skal selvfølgelig tilpasses dit ark.

Option Explicit

Const Mssql2005_USER_NAME = "bjo_bi"
Const Mssql2005_PASSWORD = "bjo_bi"
Const Mssql2005_SERVER = "SDSBQP1"
Const MyODBCVersion = "SQL server"
Const Mssql2005_database = "bjo_Bi"

Public Mssql2005_connection As ADODB

Function Mssql2005_connect()
    Set Mssql2005_connection = New ADODB.Connection
    Mssql2005_connection.ConnectionString = _
      "Driver=" & MyODBCVersion & ";" & _
      "UID=" & Mssql2005_USER_NAME & ";" & _
      "PWD=" & Mssql2005_PASSWORD & ";" & _
      "DataBase=" & Mssql2005_database & ";" & _
      "SERVER=" & Mssql2005_SERVER
    Mssql2005_connection.Open
End Function


Sub writeback()
  Dim Sql As String
  Dim c As Range
  Dim r As Long
  Call Mssql2005_connect
  r = Ark1.Range("A65536").End(xlUp).Row ' Finder nederste celle med indhold i kolonne A
  For Each c In Ark1.Range("A1:A" & r)
    lSql = "Insert Into MinTabel (Tekst1, Tekst2, Tekst3, Tekst4) Values ('" & c.Text & "','" & c.Offset(0, 1).Text & "','" & c.Offset(0, 2).Text & "','" & c.Offset(0, 3).Text & "')"
    Mssql2005_connection.Execute lSql ' Sender sql til databasen
  Next c
  Mssql2005_connection.Close
End Sub

Der er imgen grund til at ligge sql strengen ind i et recordset først. Bare send med DinForbindelse.Execute Sql

Sql scriptet for at indsætte i en tabel er følgende.
Insert Into MinTabel (Kolonne1, Kolonne2, Kolonne3) Values ('Tekst1', 1, #01-01-2007#)

Din oprindelige kode opretter en masse navne områder ( tror jeg nok det hedder ). Hvis du har gemt efter du har kørt koden, ligger de tilbage og fylder unødigt.

Koden er exekveret på 55 sekunder, og er tilsvarende med koden fra kabbak. Koden ser således ud:

Sub writeback3()
  Dim Sql As String
  Dim c As Range
  Dim r As Long
  Call Mssql2005_connect
  i = 1
  r = Worksheets("writeback").Range("A65536").End(xlUp).Row ' Finder nederste celle med indhold i kolonne A
  For Each c In Worksheets("writeback").Range("A1:A" & r)
    lSql = "Insert Into test (Date, Dimension, Value) Values ('" & c.Offset(i, 0) & "','" & c.Offset(i, 1).Text & "','" & c.Offset(i, 2).Text & "')"
    Mssql2005_connection.Execute lSql ' Sender sql til databasen
  i = i + 1
  Next c
  Mssql2005_connection.Close
End Sub

Er der en særlig grund til at du har både offset for rækker og kolonner.

c.Offset(i, 1)

Når der er loopet 2000 gange igennem koden, er værdien for i = 2000.
Det bliver altså Range("A2000" + 2000) der bliver sendt til databasen.