1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

37

Sub ToJson() '创建UTF8文本文件

myrange = Worksheets( "sheet1" ).UsedRange '通过有效数据区来选择数据

'myrange = ActiveWorkbook.Names("schoolinfo").RefersToRange '通过定义的名称来选择数据

'myrange = Range(Worksheets("sheet1").Range("a1").End(xlDown), Worksheets("sheet1").Range("a1").End(xlToRight)) '通过标题行的最大行最大列来选择数据

Total = UBound(myrange, 1) '获取行数

Fields = UBound(myrange, 2) '获取列数

Dim objStream As Object

Set objStream = CreateObject( "ADODB.Stream" )

With objStream

.Type = 2

.Charset = "UTF-8"

.Open

.WriteText "{" "total" ":" & Total & "," "contents" ":["

For i = 2 To Total

.WriteText "{"

For j = 1 To Fields

.WriteText "" "" & myrange(1, j) & "" ":" "" & Replace(myrange(i, j), "" "" , "\"" ") & " "" "

If j <> Fields Then

.WriteText ","

End If

Next

If i = Total Then

.WriteText "}"

Else

.WriteText "},"

End If

Next

.WriteText "]}"

.SaveToFile ActiveWorkbook.FullName & ".json" , 2

End With

Set objStream = Nothing

End Sub

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

Function GetJSON(Rs)

Dim JSON

dim returnStr

dim i

dim oneRecord

if Rs.eof=false and Rs.Bof=false then

returnStr= "{ " &chr(34)& "records" &chr(34)& ":["

while Rs.eof=false

for i=0 to Rs.Fields.Count -1

oneRecord=oneRecord & chr(34) & Rs.Fields(i).Name & chr(34) & ":"

oneRecord=oneRecord & chr(34) & Rs.Fields(i).Value & chr(34) & ","

Next

oneRecord=left(oneRecord,InStrRev(oneRecord, "," )-1)

oneRecord=oneRecord & "},"

returnStr=returnStr  & oneRecord

Rs.MoveNext

Wend

returnStr=left(returnStr,InStrRev(returnStr, "," )-1)

returnStr=returnStr & "]}"

end if

GetJSON=returnStr

End Function