动态设置 Listbox 的列数与列宽

VBA万岁

aman1516 发表于 2014-4-25 21:09
列宽设置没问题，但动态设置列似乎未OK

去掉了窗体初始化代码：
Private Sub TextBox1_Change()
Dim i%, j%, c As Long, s$, w$, arr, wrr, brr
wrr = Split("40; 60; 70; 150; 50; 80; 50", ";")

If TextBox1.Text = "" Then ListBox1.Clear: Exit Sub
For i = 1 To Cells(1, Cells.Columns.Count).End(xlToLeft).Column - 1
    If InStr(TextBox1.Text, Cells(1, i).Value) > 0 Then
        s = s & ":" & i
        w = w & Val(wrr(i - 1)) & ";"
    End If
Next i
If s <> "" Then
    s = Right(s, Len(s) - 1)
Else
    For i = 1 To Cells(1, Cells.Columns.Count).End(xlToLeft).Column - 1
        If InStr(Cells(1, i).Value, TextBox1.Text) > 0 Then s = i: w = Val(wrr(i - 1)): Exit For
    Next i
End If
arr = Split(s, ":")
ReDim brr(1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row, 1 To UBound(arr) + 1)
For i = 1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
    For j = 1 To UBound(arr) + 1
       brr(i, j) = Cells(i, Val(arr(j - 1))).Value
    Next j
Next i
With Me.ListBox1
    .ColumnCount = UBound(arr) + 1
    .ColumnWidths = w
    .List = brr
End With
End Sub

VBA万岁

VBA万岁 发表于 2014-4-26 08:12
去掉了窗体初始化代码：
Private Sub TextBox1_Change()
Dim i%, j%, c As Long, s$, w$, arr, wrr, br ...

附件：
指定Listbox列数与列宽并读入内容.zip (23.03 KB, 下载次数: 111)

2014-4-26 08:14 上传

点击文件名下载附件

aman1516

VBA万岁 发表于 2014-4-26 08:14
附件：

你增加几列数据看下……

wrr = Split("40; 60; 70; 150; 50; 80; 50", ";")          '预定义列宽数组
......
For i = 1 To Cells(1, Cells.Columns.Count).End(xlToLeft).Column - 1    '而这里是表头列数
    If InStr(TextBox1.Text, Cells(1, i).Value) > 0 Then
        s = s & ":" & i
        w = w & Val(wrr(i - 1)) & ";"         '由于前面既定了数组大小，当增加新列时，此句 wrr(i - 1) 与 i 变量有冲突，出错
    End If
Next i

而我前面附件是对应该列表表头的字段赋值，而空缺时，则为系统默认，所以当增加新列，就算预定义未指定列宽时，仍会按默认值设置列宽，但不会出错

期望再完善      

aman1516

由此引出新问题：如何对增加新列动态设定列宽，而不是默认值？
以17楼附件代码为基础，个人思路：
    代码里已预定义了表头与列宽，当工作表有新增加列时（不管一列或多列），则通过TEXTBOX输入的数据与预定义数组比较，若有新增加列，则通过INPUTBOX提示对新增加的列输入对应列的列宽，通过相关变量，再执行设置列宽代码。
    同时，TEXTBOX最好加上容错代码：与预定义数组比较时，若输入的表头字段不存在，则MSGBOX作出提示予以修正，就更人性化了

VBA万岁

aman1516 发表于 2014-4-26 10:46
你增加几列数据看下……

wrr = Split("40; 60; 70; 150; 50; 80; 50", ";")          '预定义列宽数组 ...

单就这个问题解决如下：

Private Sub TextBox1_Change()
Dim i%, j%, c As Long, s$, w$, wrr, arr, brr
wrr = Split("40; 60; 70; 150; 50; 80; 50" & Application.Rept(";0", Cells(1, Cells.Columns.Count).End(xlToLeft).Column - 8), ";")

If TextBox1.Text = "" Then ListBox1.Clear: Exit Sub
For i = 1 To Cells(1, Cells.Columns.Count).End(xlToLeft).Column - 1
    If InStr(TextBox1.Text, Cells(1, i).Value) > 0 Then
        s = s & ":" & i
        w = w & Val(wrr(i - 1)) & ";"
    End If
Next i
If s <> "" Then
    s = Right(s, Len(s) - 1)
Else
    For i = 1 To Cells(1, Cells.Columns.Count).End(xlToLeft).Column - 1
        If InStr(Cells(1, i).Value, TextBox1.Text) > 0 Then s = i: w = Val(wrr(i - 1)): Exit For
    Next i
End If
arr = Split(s, ":")
ReDim brr(1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row, 1 To UBound(arr) + 1)
For i = 1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
    For j = 1 To UBound(arr) + 1
       brr(i, j) = Cells(i, Val(arr(j - 1))).Value
    Next j
Next i
With Me.ListBox1
    .ColumnCount = UBound(arr) + 1
    .ColumnWidths = w
    .List = brr
End With
End Sub

VBA万岁

aman1516 发表于 2014-4-26 11:06
由此引出新问题：如何对增加新列动态设定列宽，而不是默认值？
以17楼附件代码为基础，个人思路：
    代 ...

以下代码以工作表各列列宽做为列表框列宽的参照：

Private Sub TextBox1_Change()
Dim i%, j%, c As Long, s$, w0$, w$, wrr, arr, brr

For i = 1 To Cells(1, Cells.Columns.Count).End(xlToLeft).Column - 1
    w0 = w0 & Columns(i).ColumnWidth * 5 & ";"
Next
w0 = Left(w0, Len(w0) - 1)
wrr = Split(w0, ";")

If TextBox1.Text = "" Then ListBox1.Clear: Exit Sub
For i = 1 To Cells(1, Cells.Columns.Count).End(xlToLeft).Column - 1
    If InStr(TextBox1.Text, Cells(1, i).Value) > 0 Then
        s = s & ":" & i
        w = w & Val(wrr(i - 1)) & ";"
    End If
Next i
If s <> "" Then
    s = Right(s, Len(s) - 1)
Else
    For i = 1 To Cells(1, Cells.Columns.Count).End(xlToLeft).Column - 1
        If InStr(Cells(1, i).Value, TextBox1.Text) > 0 Then s = i: w = Val(wrr(i - 1)): Exit For
    Next i
End If
arr = Split(s, ":")
ReDim brr(1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row, 1 To UBound(arr) + 1)
For i = 1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
    For j = 1 To UBound(arr) + 1
       brr(i, j) = Cells(i, Val(arr(j - 1))).Value
    Next j
Next i
With Me.ListBox1
    .ColumnCount = UBound(arr) + 1
    .ColumnWidths = w
    .List = brr
End With
End Sub

VBA万岁

VBA万岁 发表于 2014-4-26 12:07
以下代码以工作表各列列宽做为列表框列宽的参照：

Private Sub TextBox1_Change()

附件：
指定Listbox列数与列宽并读入内容.zip (24 KB, 下载次数: 65)

2014-4-26 12:10 上传

点击文件名下载附件

VBA万岁

VBA万岁 发表于 2014-4-26 12:07
以下代码以工作表各列列宽做为列表框列宽的参照：

Private Sub TextBox1_Change()

代码简化如下：

Private Sub TextBox1_Change()
Dim i%, j%, c As Long, s$, w0$, w$, wrr, arr, brr

If TextBox1.Text = "" Then ListBox1.Clear: Exit Sub
For i = 1 To Cells(1, Cells.Columns.Count).End(xlToLeft).Column - 1
    w0 = w0 & Columns(i).ColumnWidth * 5 & ";"
    If InStr(TextBox1.Text, Cells(1, i).Value) > 0 Then
        s = s & ":" & i
        w = w & Columns(i).ColumnWidth * 5 & ";"
    End If
Next i
If s <> "" Then
    s = Right(s, Len(s) - 1)
Else
    For i = 1 To Cells(1, Cells.Columns.Count).End(xlToLeft).Column - 1
        If InStr(Cells(1, i).Value, TextBox1.Text) > 0 Then s = i: w = Columns(i).ColumnWidth * 5 & ";": Exit For
    Next i
End If
arr = Split(s, ":")
ReDim brr(1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row, 1 To UBound(arr) + 1)
For i = 1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
    For j = 1 To UBound(arr) + 1
       brr(i, j) = Cells(i, Val(arr(j - 1))).Value
    Next j
Next i
With Me.ListBox1
    .ColumnCount = UBound(arr) + 1
    .ColumnWidths = w
    .List = brr
End With
End Sub

VBA万岁

VBA万岁 发表于 2014-4-26 12:18
代码简化如下：

Private Sub TextBox1_Change()

附件如下：
指定Listbox列数与列宽并读入内容.zip (23.18 KB, 下载次数: 172)

2014-4-26 12:19 上传

点击文件名下载附件

aman1516

VBA万岁 发表于 2014-4-26 12:20
附件如下：

以下代码以工作表各列列宽做为列表框列宽的参照：

good idea !