Dim Rs_Data As New AdoDB.Recordset
Dim Irowcount As Long
Dim Icolcount As Long
' Dim xlApp As New Excel.Application
' Dim xlBook As Excel.Workbook
' Dim xlSheet As Excel.Worksheet
' Dim xlQuery As Excel.QueryTable
' Dim ExApp As Object
On Error Resume Next
Set ExApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Err.Clear
Set ExApp = CreateObject("Excel.Application")
If Err.Number <> 0 Then
Err.Clear
MsgBox "本机上未安装EXCEL，请先安装后再运行本程序！", vbInformation
Else
'MsgBox "您的电脑中已安装Word程序!", vbInformation
ExApp.quit
End If
Else
' MsgBox "e已启动，请先退出后再运行本程序！", vbInformation
End If
On Error GoTo Errc
' Dim xlApp As Object
' Dim xlBook As Object
' Dim xlSheet As Object
' Dim xlQuery As Object
With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = Conn
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = SQLofBB4 ' strOpen
.Open
End With
With Rs_Data
If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Sub
End If
'记录总数
Irowcount = .RecordCount
'字段总数
Icolcount = .Fields.Count
End With
Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().Add
Set xlSheet = xlBook.Worksheets("sheet1")
' Application对象
' Workbook对象
' Worksheet对象
' Range对象
xlApp.Visible = True
'添加查询语句，导入EXCEL数据
Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))
With xlQuery
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = 1 ' xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
End With
xlQuery.FieldNames = True '显示字段名
xlQuery.Refresh
With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体"
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Size = 10
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
'标题字体加粗
.Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = 1 ' xlContinuous
'设表格边框样式
End With
' xlSheet.RANGE(.Cells(4, 4)).End(xlDown).offset(3, 0).value = " 死毕哥 "
With xlSheet.pagesetup
.Orientation = 2 'xlLandscape
End With
I = 2
Dim lngFirstRow As Long
Dim blnInit As Boolean
blnInit = False
Dim lngMaxRow As Long
lngMaxRow = xlSheet.Range("A3").End(-4121).Row
lngMaxRow = xlSheet.Range("A1").End(-4121).Row ' 2019-12-11
'**************************************************************************************************
' Dim objRange As Object
' Set objRange = xlSheet.Range(strRange)
'
' Dim strData As String
' strData = objRange.Item(1, 1)
'
' objRange.Clear
' objRange.Merge
' objRange.value = strData
Dim objRange As Object
Dim strData As String
' Set objRange = xlSheet.Range(strRange)
' strData = objRange.Item(1, 1)
'
' objRange.Clear
' objRange.Merge
' objRange.value = strData
Dim j As Long
Dim A As Long, B As Boolean, Index As Long, C As String
' A = xlSheet.Range("R" & "2")
A = xlSheet.Range("S" & "2")
C = A
B = False 'b 相同时为FALSE 不同时为TRUE
Index = 0
For I = 1 To lngMaxRow
If I = 1 Then '1如果为第一条记录不处理
Index = 1
Else '1如果为第一条之后的记录
'If A = xlSheet.Range("R" & CStr(1 + I)) Then '2 如果相同 则 INDEX加1
If A = xlSheet.Range("S" & CStr(1 + I)) Then '2 如果相同 则 INDEX加1
Index = Index + 1
Else '2 如果不相同 则
If Index > 1 Then
strRange = "P" & I - Index + 1 & ":P" & I
Set objRange = xlSheet.Range(strRange)
strData = objRange.Item(1, 1)
objRange.Clear
objRange.Merge
objRange.value = strData
strRange = "Q" & I - Index + 1 & ":Q" & I
Set objRange = xlSheet.Range(strRange)
strData = objRange.Item(1, 1)
objRange.Clear
objRange.Merge
objRange.value = strData
strRange = "R" & I - Index + 1 & ":R" & I
Set objRange = xlSheet.Range(strRange)
strData = objRange.Item(1, 1)
objRange.Clear
objRange.Merge
objRange.value = strData
strRange = "T" & I - Index + 1 & ":T" & I
Set objRange = xlSheet.Range(strRange)
strData = objRange.Item(1, 1)
objRange.Clear
objRange.Merge
objRange.value = strData
End If
Index = 1
A = xlSheet.Range("S" & CStr(1 + I))
End If
End If
' C = xlSheet.Range("R" & CStr(1 + I + 1))
C = xlSheet.Range("S" & CStr(1 + I + 1))
If C = "" Then
If Index > 1 Then
strRange = "P" & (I - Index + 2 & ":P" & I + 1)
Set objRange = xlSheet.Range(strRange)
strData = objRange.Item(1, 1)
objRange.Clear
objRange.Merge
objRange.value = strData
strRange = "Q" & (I - Index + 2 & ":Q" & I + 1)
Set objRange = xlSheet.Range(strRange)
strData = objRange.Item(1, 1)
objRange.Clear
objRange.Merge
objRange.value = strData
'strRange = "S" & (I - Index + 2 & ":S" & I + 1)
strRange = "R" & (I - Index + 2 & ":R" & I + 1)
Set objRange = xlSheet.Range(strRange)
strData = objRange.Item(1, 1)
objRange.Clear
objRange.Merge
objRange.value = strData
strRange = "T" & (I - Index + 2 & ":T" & I + 1)
Set objRange = xlSheet.Range(strRange)
strData = objRange.Item(1, 1)
objRange.Clear
objRange.Merge
objRange.value = strData
End If
End If
Next I
'******************************************************************************************************
