恳请高手指点----如何将sql查询的记录，分别插入到EXCEL的不同单元格？

Question

yf,yw与sx分别插入到b1,b3???
三个字段插入到两个？

Answer 1

想写b1--b3，应该是：name 插入到a1 ,sex 插入a3
yf,yw与sx分别插入到b1,b2,b3

Answer 2

通过xls的VBA功能，应该比较简单，下例：
redBom.MoveFirst
    For i = 11 To intRed
        Worksheets("costbom").Cells(i, 1) = i - 10
        Worksheets("costbom").Cells(i, 2) = redBom!物料代码 + redBom!物料名称
        Worksheets("costbom").Cells(i, 3) = redBom!规格型号
        Worksheets("costbom").Cells(i, 4) = Format(redBom!单个消耗, "####.######")   '单耗保留小数6位
        Worksheets("costbom").Cells(i, 5) = redBom!单价
        Worksheets("costbom").Cells(i, 6) = redBom!单位
        Worksheets("costbom").Cells(i, 7) = redBom!金额
        
                redBom.MoveNext
    Next i

Answer 3

Dim iCmd As Object
    Dim iRe As Object
    Dim iConc$
    
    Dim xlQuery As Excel.QueryTable
    Dim xlSheet As Excel.Worksheet    'Êý¾Ý¿âÁ¬½Ó×Ö·û´®
   iConc = "Provider=SQLOLEDB.1;Persist Security Info=True;" & _
        "User ID=sa;Password=zhangzs;Initial Catalog=Movex12;Data Source=zhangzs"
        Set iCmd = CreateObject("ADODB.Command")
    With iCmd
        .ActiveConnection = iConc
        .CommandType = 4
        .CommandText = "facility"  'Òªµ÷ÓõĴ洢¹ý³ÌÃû
        .Parameters.Refresh
        .Parameters("@hth") = Format(TxtDate.Text)   '´æ´¢¹ý³ÌµÄ²ÎÊý@hth
        Set iRe = .Execute
       ' MsgBox iRe.State
    End With
        
    Set xlSheet = ActiveWorkbook.Sheets(2)  'ÔÚ¹¤×÷±íÖÐÏÔʾ½á¹û
    Set xlQuery = xlSheet.QueryTables.Add(iRe, xlSheet.Range("a5"))
    With xlQuery
        .FieldNames = True  'ÏÔʾ×Ö¶ÎÃû
        .RowNumbers = False
        .FillAdjacentFormulas = True
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .Refresh
    End With
   iRe.Close
    Set iRe = Nothing
    Set iCmd = Nothing
    Set xlSheet = Nothing
    Set xlQuery = Nothing这样的话，将会把存储过程查到的结果放进EXCEL
但是我想的是把查询结果的某行某列放到一个EXCEL单元格里
不知道我说明白了没？

Answer 4

Private Sub cmdOK_Click()
Dim rstserver As New adodb.Recordset
Dim rstserver2 As New adodb.Recordset
'定义到excel文件
Dim MyXL As Object   '用于存放Microsoft Excel 引用的变量。
Dim ExcelWasNotRunning As Boolean   '用于最后释放的标记。
Const WM_USER = 1024
Dim hWnd As Long, irow As Integer
Dim strfile As String, rstlocal As New adodb.Recordset
Dim strDummy As String, strStart As String, strEnd As String
Dim intTs As Integer
Dim icol As Long'定义dt2为时间选择，把dtpstart的value值传给dt2
Dim dt2 As Date
dt2 = dtpStart.Value
Dim place As Integer'循环语句是为了让默认值换成datacombo的值2
If DataCombo1.BoundText = "杭州" Then
   DataCombo1.Text = 2
End If
place = DataCombo1.BoundText
'测试 Microsoft Excel 的副本是否在运行。
 On Error Resume Next   '延迟错误捕获。
'不带第一个参数调用 Getobject 函数将返回对该应用程序的实例的引用。
'如果该应用程序不在运行，则会产生错误。
   Set MyXL = GetObject(, "Excel.Application")
   If Err.Number <> 0 Then ExcelWasNotRunning = True
   Err.Clear   '如果发生错误则要清除 Err 对象。'检测 Microsoft Excel。如果 Microsoft Excel 在运行，则将其加入运行对象表。
'如果 Excel 在运行，则该 API 调用将返回其句柄。
   hWnd = FindWindow("XLMAIN", 0)
   If hWnd = 0 Then   '0 表示没有 Excel 在运行。
      Set MyXL = Nothing
      Set MyXL = CreateObject("Excel.Application")
      
   Else
   'Excel 在运行，因此可以使用 SendMessage API函数将其放入运行对象表。
      SendMessage hWnd, WM_USER + 18, 0, 0
   End If    '将对象变量设为对要看的文件的引用。
       strfile = App.Path & "\datarepot2_everyday.xls"
       Set MyXL = GetObject(strfile)
    
    '设置其 Application 属性，显示 Microsoft Excel。
    '然后使用 MyXL 对象引用的 Windows 集合
    '显示包含该文件的实际窗口。
       MyXL.Application.Visible = True
       MyXL.Parent.Windows(1).Visible = True
       MyXL.Sheets("sheet1").Activate
    '把数据导入sheet1工作表的对应单元格中
    
    '统计事件的报告方式
        Dim strselect As String
        With rstserver
            If .State = adStateOpen Then .Close
            .ActiveConnection = gcnnReport
            .CursorLocation = adUseClient
            .CursorType = adOpenDynamic
            .LockType = adLockOptimistic
            .Source = "select report_id,count(Report_id) aa from sggl_info  where date='" & dt2 & "'and station_id='" & place & "' group by report_id"
            .Open
            .MoveFirst
            irow = 6
            icol = 3
            While Not .EOF
                strselect = "e" & Trim(Str(irow)) & ":d" & Trim(Str(irow))
                MyXL.Sheets("sheet1").Range(strselect).Select
                MyXL.Sheets("sheet1").Range(strselect).Activate
                MyXL.Sheets("sheet1").Cells(irow, icol + .Fields("report_id")) = .Fields("aa")
                .MoveNext
            Wend
        End With
        
    '统计事故数
        With rstserver2
           If .State = adStateOpen Then .Close
           .ActiveConnection = gcnnReport
           .CursorLocation = adUseServer
           .CursorType = adOpenDynamic
           .LockType = adLockOptimistic
           .Source = "select type_id,count(type_id) bb from sggl_info where date='" & dt2 & "'and station_id='" & place & "'and type_id>1 group by type_id"
           .Open
           .MoveFirst
           irow = 6
           icol = 8
           While Not .EOF
           strselect = "e" & Trim(Str(irow)) & ":d" & Trim(Str(irow))
                MyXL.Sheets("sheet1").Range(strselect).Select
                MyXL.Sheets("sheet1").Range(strselect).Activate
                MyXL.Sheets("sheet1").Cells(irow, icol + .Fields("type_id")) = .Fields("bb")
                .MoveNext
           Wend
         End With
         
             '创建值班室每日汇总表和目录
        MkDir (App.Path & "\值班室每日汇总表")
        MyXL.SaveAs App.Path & "\值班室每日汇总表\" & "值班室每日汇总表_" & Format(dt2, "yyyymmdd") & ".xls"
        
    If DataCombo1.BoundText = 2 Then
    DataCombo1.Text = "杭州"
    End If
    
End Sub

Answer 5

While Not .EOF
                strselect = "e" & Trim(Str(irow)) & ":d" & Trim(Str(irow))
                MyXL.Sheets("sheet1").Range(strselect).Select
                MyXL.Sheets("sheet1").Range(strselect).Activate
                MyXL.Sheets("sheet1").Cells(irow, icol + .Fields("report_id")) = .Fields("aa")
                .MoveNext
            Wend
//这个是关键几句

Answer 6

Private Sub Check_Click()
     Dim strCnn As String
    Dim cnn1 As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim pzh As ADODB.Recordset
    
    'strCnn = "DSN=DL380-1;uid=sa;pwd=tpcims;database=MovexTest"
    strCnn = "DSN=zhangzs;uid=sa;pwd=zhangzs;database=Movex12"
    Set cnn1 = New ADODB.Connection
    cnn1.Open strCnn
    
    Set pzh = New ADODB.Recordset
    pzh.CursorType = adOpenStatic
    pzh.Open "select * from JTQSanLv where lh='" & Txt_hth.Text & "'", strCnn, , , adCmdText
   ' If pzh.RecordCount = 1 Then
        Range("A5") = Txt_hth.Text
        Range("B5") = pzh!&Icirc;&iuml;&Aacute;&Iuml;&ordm;&Aring;
    'End If
    pzh.CloseEnd Sub怎么提示我没数据源呢？

Answer 7

Sub po_write()
  Dim myCn As New ADODB.Connection
  Dim myrs As New ADODB.Recordset
  Dim arr(6, 2) As Integer '汇总各部门项数、件数、金额
  Dim z As Integer
 
  'strcon = "PROVIDER=SQLOLEDB;SERVER=tpsrv;UID=sa;PWD=;DATABASE=bj_report"
  strcon = "PROVIDER=SQLOLEDB;SERVER=DL380-1;UID=sa;PWD=tpcims;DATABASE=bj_report" 'DL380-1
  On Error GoTo Error:
  myCn.ConnectionString = strcon
  myCn.Open
  myrs.ActiveConnection = myCn
  'mystr = "execute  facility '" + Range("H2") + "'"
  mystr = "execute  po_order '" + Range("H2") + "'"
  myrs.Open mystr '为 Recordset 赋值
  
  If myrs.EOF Then
   MsgBox "系统中无此合同!", vbOKOnly, "错误"
   Range("H2").Value = ""
   Exit Sub
  End If
  Worksheets("审批表").Unprotect Password:="zhangzs"
  Worksheets("承揽合同").Unprotect Password:="zhangzs"
  Worksheets("承揽合同附页").Unprotect Password:="zhangzs"  n = 5
  m = 8
  p = 8
  Range("C9") = Trim(myrs!采购员)
  hx = 0
  myrs.MoveFirst
  Do While Not myrs.EOF
  hx = hx + 1  If n > 6 Then
    Rows(n - 1 & ":" & n - 1).Copy
    Rows(n & ":" & n).Insert Shift:=xlDown
  End If
  
  Range("C2") = Trim(myrs!供应商名称)
  Range("K2") = Trim(myrs!专业类别)
 
  Worksheets("承揽合同").Range("Z4") = Trim(myrs!专业类别)
  Worksheets("承揽合同").Range("AC4") = Trim(myrs!受控)
  Worksheets("承揽合同").Range("AG4") = Trim(myrs!合同签定日期) '审批表里所要的值
  Cells(n, 1) = Trim(myrs!序号)
  Cells(n, 2) = Trim(myrs!管理号)
  Cells(n, 3) = Trim(myrs!备件编号)
  Cells(n, 4) = Trim(myrs!备件名称图号)
  Cells(n, 11) = Trim(myrs!计量单位)
  Cells(n, 12) = Trim(myrs!采购数量)
  Cells(n, 13) = Trim(myrs!供方价格)
  Cells(n, 14) = Trim(myrs!单价)
  Cells(n, 15) = Cells(n, 12) * Cells(n, 14)
  Cells(n, 16) = Trim(myrs!计划单价)
  
  '在承揽合同里提取前三条记录
  
  If m < 11 Then
  
  Worksheets("承揽合同").Cells(m, 1) = Trim(myrs!序号)
  Worksheets("承揽合同").Cells(m, 2) = Trim(myrs!备件名称图号)
  Worksheets("承揽合同").Cells(m, 21) = Trim(myrs!计量单位)
  Worksheets("承揽合同").Cells(m, 23) = Trim(myrs!采购数量)
  Worksheets("承揽合同").Cells(m, 26) = Trim(myrs!单价)
  Worksheets("承揽合同").Cells(m, 35) = Trim(myrs!交货日期)
  
  
  End If
  
  '在承揽合同附页里提取从第四条到最后的记录
    If p > 12 Then
    Worksheets("承揽合同附页").Rows(p - 4 & ":" & p - 4).Copy
    Worksheets("承揽合同附页").Rows(p - 3 & ":" & p - 3).Insert Shift:=xlDown
    End If
    
    If n > 7 Then
    Worksheets("承揽合同附页").Cells(p - 3, 1) = Trim(myrs!序号)
    Worksheets("承揽合同附页").Cells(p - 3, 2) = Trim(myrs!备件名称图号)
    Worksheets("承揽合同附页").Cells(p - 3, 4) = Trim(myrs!计量单位)
    Worksheets("承揽合同附页").Cells(p - 3, 5) = Trim(myrs!采购数量)
    Worksheets("承揽合同附页").Cells(p - 3, 6) = Trim(myrs!单价)
    Worksheets("承揽合同附页").Cells(p - 3, 7) = myrs!单价 * myrs!采购数量
    Worksheets("承揽合同附页").Cells(p - 3, 9) = Trim(myrs!交货日期)    End If
    
    
     Select Case Trim(myrs!需求部门)    ' 判断 需求部门。
     Case "炼钢厂"
         arr(0, 0) = arr(0, 0) + 1
         arr(0, 1) = arr(0, 1) + myrs!采购数量
         arr(0, 2) = arr(0, 2) + myrs!采购数量 * myrs!单价
     Case "轧管厂"
        
         arr(1, 0) = arr(1, 0) + 1
         arr(1, 1) = arr(1, 1) + myrs!采购数量
         arr(1, 2) = arr(1, 2) + myrs!采购数量 * myrs!单价     Case "管加工厂"
     
         arr(2, 0) = arr(2, 0) + 1
         arr(2, 1) = arr(2, 1) + myrs!采购数量
         arr(2, 2) = arr(2, 2) + myrs!采购数量 * myrs!单价
     
     Case "丝扣基地"
     
         arr(3, 0) = arr(3, 0) + 1
         arr(3, 1) = arr(3, 1) + myrs!采购数量
         arr(3, 2) = arr(3, 2) + myrs!采购数量 * myrs!单价
     
     Case "能源部"
     
         arr(4, 0) = arr(4, 0) + 1
         arr(4, 1) = arr(4, 1) + myrs!采购数量
         arr(4, 2) = arr(4, 2) + myrs!采购数量 * myrs!单价
     
     Case "轧管二套"
          arr(5, 0) = arr(5, 0) + 1
         arr(5, 1) = arr(5, 1) + myrs!采购数量
         arr(5, 2) = arr(5, 2) + myrs!采购数量 * myrs!单价
     Case Else    ' 其他部门。
    
         arr(6, 0) = arr(6, 0) + 1
         arr(6, 1) = arr(6, 1) + myrs!采购数量
         arr(6, 2) = arr(6, 2) + myrs!采购数量 * myrs!单价End Select
 ' Columns("c").AutoFit  '列宽问题
  myrs.MoveNext
  n = n + 1
  m = m + 1
  p = p + 1
  Loop
  With Worksheets("审批表").Range("a1:a500")
        Set c = .Find("∑", LookIn:=xlValues)
        If Not c Is Nothing Then
            Worksheets("审批表").Range("E" & c.Row).Value = "本合同共" & hx & "项记录"
        End If
    End With
  If n > 6 Then
     Worksheets("审批表").Rows(n & ":" & n).EntireRow.Hidden = True
  End If
  If (p - 3 > 9) Then
    Worksheets("承揽合同附页").Rows(p - 3 & ":" & p - 3).EntireRow.Hidden = True
  End If
  '
    
    '用来判断是向哪类合同写数据
    z = 0
    For i = 0 To 6
    z = z + arr(i, 2)
    Next i
    
    '写数据,写完数据之后加保护
    For i = 0 To 2
        For j = 0 To 6
        
        If (z > 100) Then   '此处的常量需要再一次确认
         Worksheets("B类合同").Unprotect Password:="zhangzs"
        Worksheets("B类合同").Cells(9 + i, 3 + j) = IIf(arr(j, i) = 0, "", arr(j, i))
        Worksheets("B类合同").Protect Password:="zhangzs", DrawingObjects:=True, contents:=True, Scenarios:=True        Else
        Worksheets("C类合同").Unprotect Password:="zhangzs"
        Worksheets("C类合同").Cells(9 + i, 3 + j) = IIf(arr(j, i) = 0, "", arr(j, i))
        Worksheets("C类合同").Protect Password:="zhangzs", DrawingObjects:=True, contents:=True, Scenarios:=True
        End If
        Next j
     Next i
      Worksheets("审批表").Protect Password:="zhangzs", DrawingObjects:=True, contents:=True, Scenarios:=True
  Worksheets("承揽合同").Protect Password:="zhangzs", DrawingObjects:=True, contents:=True, Scenarios:=True
    Worksheets("承揽合同附页").Protect Password:="zhangzs", DrawingObjects:=True, contents:=True, Scenarios:=True  myrs.Close
  myCn.Close
  Exit Sub
Error:
  MsgBox Err.Description, vbOKOnly, "Error Message"
  
End Sub