怎么编译错误？ - 编程论坛

#2

风吹过b2018-04-30 11:37

List1.List 是listbox 的一个内置对象，
所以不能使用等号赋值。

对这个对象，VB6 提供了一些动作和属性来操作它。
具体你查相关书籍吧！百度也应该有结果的。

#3

dsasada2018-05-01 11:02

回复 2楼风吹过b

Sub abc()
    Dim i As Integer, j As Integer, R As Integer
    Dim d As Object
    Dim ar, br(), m As Integer
    Set d = CreateObject("Scripting.Dictionary")
    R = Sheets(1).[K65536].End(3).Row
    ar = Sheets(1).Range("K5:M" & R)
    ReDim br(1 To UBound(ar), 1 To 2)
    For i = 1 To UBound(ar)
        If Not d.Exists(ar(i, 1)) Then
            m = m + 1
            d(ar(i, 1)) = m
            br(m, 1) = ar(i, 1)
            br(m, 2) = ar(i, 3)
        Else
            br(d(ar(i, 1)), 2) = br(d(ar(i, 1)), 2) + ar(i, 3)
        End If
    Next
    For i = 1 To m
        For j = 1 To 2
            List1.AddItem brr(i, j)
        Next
    Next

现在listbox能正常显示数据，就是一行显示一个数据，怎么才能让每2个数据显示在一行，是不是listbox不能显示多列？

[此贴子已经被作者于2018-5-6 20:42编辑过]

#4

风吹过b2018-05-01 17:09

    For i = 1 To m
            List1.AddItem brr(i, 1) & " " & brr(i,2)
    Next

自己拼成一行添加进去

#5

dsasada2018-05-02 22:50

回复 4楼风吹过b

谢谢！！！

[此贴子已经被作者于2018-5-6 20:42编辑过]

#6

asad2019-12-24 09:58

Private Sub List1_Click()
    Printer.ScaleMode = vbTwips
    Printer.Orientation = vbPRORPortrait
    Printer.FontSize = 14
    For i = 0 To List1.ListCount - 5
        Printer.CurrentX = 300
        Printer.CurrentY = (i + 1) * 400
        Printer.Print List1.List(i)
    Next
    Printer.EndDoc
End Sub

#7

asad2020-01-07 10:29

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  On Error Resume Next
  Application.DisplayAlerts = False
  ActiveWorkbook.Sheets("abc").Delete
  ActiveWorkbook.Save
  Application.DisplayAlerts = True
End Sub

Private Sub Workbook_Open()
  ThisWorkbook.Activate
  ActiveWindow.Visible = False
End Sub

Sub cop()

End Sub
Sub escape()

End Sub
Sub back()

End Sub

[此贴子已经被作者于2020-1-7 10:35编辑过]

#8

asad2020-01-16 11:16

Sub text()
    Dim d As Object, arr, brr(1 To 1000, 1 To 3), wb As Excel.Workbook, mypath As String, myname As String, m As Long
    xlapp.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")
    mypath = xlapp.ActiveWorkbook.Path & "\"
    myname = Dir(mypath & "*.xls")
    Do While myname <> ""
        If myname <> xlapp.ActiveWorkbook.Name Then
            Set wb = GetObject(mypath & myname)
            With wb
                With .Sheets(1)
                    r = .Cells(.Rows.Count, 6).End(xlUp).Row
                    arr = .Range("a5:am" & r)
                    For i = 1 To UBound(arr)
                        If arr(i, 39) Like "*aa*" Then
                            If arr(i, 24) Like "*bb*" Then
                                s = "bb"
                            Else
                                s = arr(i, 24)
                            End If
                            If Not d.Exists(s) Then
                                m = m + 1
                                d(s) = m
                                brr(m, 1) = 1
                                brr(m, 2) = arr(i, 10)
                                brr(m, 3) = s
                            Else
                                brr(d(s), 1) = brr(d(s), 1) + 1
                                brr(d(s), 2) = brr(d(s), 2) + arr(i, 10)
                            End If
                        End If
                    Next
                End With
                .Close False
            End With
        End If
        myname = Dir()
    Loop
    If m > 0 Then
        With xlapp.Sheets(1)
            .[d18].Resize(m, 3) = brr
        End With
    End If
    xlapp.ScreenUpdating = True
End Sub

#9

asad2020-01-16 11:20

Sub text()
    Dim d As Object, d1 As Object, d2 As Object, rng As Excel.Range, arr, MyFile As String, i As Long, j As Long, k As Long, l, m, n, s As String
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
    arr = xlapp.Range("t6:ah" & xlapp.Cells(xlapp.Rows.Count, "f").End(xlUp).Row)
    For i = 1 To UBound(arr)
        If Len(arr(i, 1)) Then
            If arr(i, 1) Like "*a*" Then
                d("a") = d("a") + 1
            ElseIf arr(i, 1) Like "*b*" Then
                d("b") = d("b") + 1
            ElseIf arr(i, 1) Like "*c*" Then
                d("c") = d("c") + 1
            Else
                d(arr(i, 1)) = d(arr(i, 1)) + 1
            End If
            If arr(i, 13) Like "*x*" Then a = a + 1
            k = k + 1
            m = m + xlapp.Cells(i + 5, 10)
            xlapp.Rows(i + 5).Font.ColorIndex = 3
        Else
            xlapp.Rows(i + 5).Font.ColorIndex = 1
        End If
        If Len(arr(i, 7)) Then d1(arr(i, 7)) = ""
        If Len(arr(i, 15)) Then d2(arr(i, 15)) = ""
        j = j + 1
    Next
    For Each aa In d.keys
        s1 = s1 + 1
        s = s & Chr(10) & s1 & "." & aa & "：" & d(aa) & "k"
    Next
    For Each bb In d1.keys
        s2 = s2 + 1
        s3 = s3 & Chr(10) & s2 & "." & bb
    Next
    s = Mid(s, 2)
    s = IIf(a > 0, s & "  (s1" & a & "k)", s)
    l = Mid(s3, 2)
    n = Join(d2.keys, "；")
    xlapp.DisplayAlerts = False
    MyFile = Dir(xlapp.ActiveWorkbook.Path & "\*.xls")
    xlapp.Workbooks.Open FileName:=xlapp.ActiveWorkbook.Path & "\" & MyFile
    On Error Resume Next
    Set rng = xlapp.InputBox("请选粘贴地址：", , "$E$14", Type:=8)
    xlapp.Range(rng.Address) = IIf(Len(s) > 0, s, "")
    xlapp.Range(rng.Address).Offset(, -2) = j
    xlapp.Range(rng.Address).Offset(, -1) = k
    xlapp.Range(rng.Address).Offset(, 1) = l
    xlapp.Range(rng.Address).Offset(, 2) = m
    xlapp.Range(rng.Address).Offset(, 3) = n
    xlapp.DisplayAlerts = True
End Sub

#10

asad2020-01-16 11:22

Sub text()
    Dim d As Object, dic As Object, rng As Excel.Range, arr, brr(), crr, MyFile As String, a, i As Long, j As Long, k As Long, l, m, n, s As String, tmp, artmp
    Set d = CreateObject("scripting.dictionary")
    Set dic = CreateObject("scripting.dictionary")
    arr = xlapp.Range("g5:ag" & xlapp.Range("g65536").End(xlUp).Row)
    ReDim brr(1 To UBound(arr), 1 To 3)
    For i = 1 To UBound(arr)
        If Len(arr(i, 13)) Then
            s = "(" & arr(i, 1) & "/" & Format(arr(i, 2), "0.00") & "*" & arr(i, 3) & ")"
            If Not d.Exists(s) Then
                d(s) = d.Count + 1
                brr(d(s), 1) = s
            End If
            brr(d(s), 2) = brr(d(s), 2) + 1
            dic(s & "|" & arr(i, 13)) = dic(s & "|" & arr(i, 13)) + 1
            k = k + 1: l = l + arr(i, 25): n = n + arr(i, 27)
        End If
        j = j + 1
    Next
    For Each tmp In dic.keys
        artmp = Split(tmp, "|")
        brr(d(artmp(0)), 3) = brr(d(artmp(0)), 3) & "," & dic(tmp) & "|" & artmp(1)
    Next
    s = ""
    For i = 1 To d.Count
        If brr(i, 2) = Val(Mid(brr(i, 3), 2)) Then
            s = s & "；" & brr(i, 2) & "|" & brr(i, 1) & Split(brr(i, 3), "|")(1)
        Else
            s = s & "；" & brr(i, 2) & "|" & brr(i, 1) & ":" & Mid(brr(i, 3), 2)
        End If
    Next
    a = Mid(Replace(s, "|", "aaa"), 2)
    d.RemoveAll
    crr = xlapp.Range("AA5:AA" & xlapp.Range("g65536").End(xlUp).Row)
    For i = 1 To UBound(crr)
        If Len(crr(i, 1)) Then d(crr(i, 1)) = ""
    Next
    m = Join(d.keys, "/")
    xlapp.DisplayAlerts = False
    MyFile = Dir(xlapp.ActiveWorkbook.Path & "\*.xls")
    xlapp.Workbooks.Open FileName:=xlapp.ActiveWorkbook.Path & "\" & MyFile
    On Error Resume Next
    Set rng = xlapp.InputBox("请选粘贴地址：", , "$E$25", Type:=8)
    xlapp.Range(rng.Address) = IIf(Len(a) > 0, a & "；计" & Format(l, "0.00") & "。", "")
    xlapp.Range(rng.Address).Offset(, -2) = j
    xlapp.Range(rng.Address).Offset(, -1) = k
    xlapp.Range(rng.Address).Offset(, 1) = l
    xlapp.Range(rng.Address).Offset(, 2) = m
    xlapp.Range(rng.Address).Offset(, 3) = n
    xlapp.DisplayAlerts = True
End Sub

#11

asad2020-01-16 11:25

Sub text()
    Dim MyFile, i As Long, sh As Excel.Worksheet
    MyFile = xlapp.GetOpenFilename(fileFilter:="Excel文件(*.xls),*.xls", Title:="选择Excel文件", MultiSelect:=True)
    If TypeName(MyFile) = "Boolean" Then Exit Sub
    xlapp.ScreenUpdating = False
    Set sh = xlapp.ActiveSheet
    For i = 1 To UBound(MyFile)
        If MyFile(i) <> xlapp.ActiveWorkbook.FullName Then
            With GetObject(MyFile(i))
                .Sheets("sheet1").UsedRange.Offset(5).Copy sh.Range("a" & xlapp.Rows.Count).End(xlUp).Offset(1)
                .Close 0
             End With
        End If
    Next
    xlapp.ScreenUpdating = True
End Sub