adodb执行查询oracle慢,adodb.stream逐行读写过慢，求优化VBA

需求是这样的：要将EXCEL中的数据转为txt和json，由于泰文直接转出会乱码再手动转为utf-8就没用了，所以需要在VBA中直接转变为utf-8，但是由于文本量过大，所以现在运行一次宏要好久，求各位大大帮忙可以优化一下，怎么能变得快一些

代码如下：

Const adTypeBinary = 1

Const adTypeText = 2

Const adSaveCreateNotExist = 1

Const adSaveCreateOverWrite = 2

Sub exportJosn()

Dim s As String

Dim fullName As String

Dim Data1 As String

Dim rng As Range

Dim xLen As Long

Dim yLen As Long

Dim r1 As Long

Dim c1 As Long

fullName = Replace(ThisWorkbook.fullName, ".xlsm", ".json.txt")

fullName = Replace(fullName, "公告", "Attributes")

xLen = Range("a1").CurrentRegion.Columns.Count

yLen = Range("a1").CurrentRegion.Rows.Count

' Open fullName For Output As #1

' Print #1, "{"

tempStr = "{" & VBA.Constants.vbCrLf

For r1 = 2 To yLen

s = ""

For c1 = 1 To xLen

If (Application.IsNumber(Cells(r1, c1).Value)) Then

s = s & Chr(34) & Cells(1, c1).Value & Chr(34) & " : " & Cells(r1, c1).Value

Else

s = s & Chr(34) & Cells(1, c1).Value & Chr(34) & " : " & Chr(34) & Cells(r1, c1).Value & Chr(34)

End If

If c1 < xLen Then

s = s & ", "

End If

Next

If r1 < yLen Then

' Print #1, Chr(34) & Cells(r1, 1).Value & Chr(34) & " : {" & s & "}, "

tempStr = tempStr & Chr(34) & Cells(r1, 1).Value & Chr(34) & " : {" & s & "}, " & VBA.Constants.vbCrLf

Else

' Print #1, Chr(34) & Cells(r1, 1).Value & Chr(34) & " : {" & s & "}"

tempStr = tempStr & Chr(34) & Cells(r1, 1).Value & Chr(34) & " : {" & s & "}" & VBA.Constants.vbCrLf

End If

Next

' Print #1, "}"

tempStr = tempStr & "}" & VBA.Constants.vbCrLf

'  Close #1

Set Stream = CreateObject("adodb.stream")

Stream.Open

Stream.Type = adTypeText

Stream.Charset = "UTF-8"

Stream.writetext tempStr

Stream.flush

Stream.savetofile fullName, adSaveCreateOverWrite

Stream.Close

Set Stream = Nothing

fullName = Replace(ThisWorkbook.fullName, ".xlsm", ".json")

fullName = Replace(fullName, "公告", "服务器用表")

xLen = Range("a1").CurrentRegion.Columns.Count

yLen = Range("a1").CurrentRegion.Rows.Count

'  Open fullName For Output As #1

'  Print #1, "{"

tempStr = "{" & VBA.Constants.vbCrLf

For r1 = 2 To yLen

s = ""

For c1 = 1 To xLen

If (Application.IsNumber(Cells(r1, c1).Value)) Then

s = s & Chr(34) & Cells(1, c1).Value & Chr(34) & " : " & Cells(r1, c1).Value

Else

s = s & Chr(34) & Cells(1, c1).Value & Chr(34) & " : " & Chr(34) & Cells(r1, c1).Value & Chr(34)

End If

If c1 < xLen Then

s = s & ", "

End If

Next

If r1 < yLen Then

' Print #1, Chr(34) & Cells(r1, 1).Value & Chr(34) & " : {" & s & "}, "

tempStr = tempStr & Chr(34) & Cells(r1, 1).Value & Chr(34) & " : {" & s & "}, " & VBA.Constants.vbCrLf

Else

' Print #1, Chr(34) & Cells(r1, 1).Value & Chr(34) & " : {" & s & "}"

tempStr = tempStr & Chr(34) & Cells(r1, 1).Value & Chr(34) & " : {" & s & "}" & VBA.Constants.vbCrLf

End If

Next

'Print #1, "}"

tempStr = tempStr & "}" & VBA.Constants.vbCrLf

' Close #1

Set Stream = CreateObject("adodb.stream")

Stream.Open

Stream.Type = adTypeText

Stream.Charset = "UTF-8"

Stream.writetext tempStr

Stream.flush

Stream.savetofile fullName, adSaveCreateOverWrite

Stream.Close

Set Stream = Nothing

MsgBox ("ok!")

End Sub