[已解决]代码求修改。。。追加问题

fcdd

我想把代码中的红色代码  改为 数据来源 根据Sheet2，A列B列为了以后方便 添加
Private Sub CommandButton1_Click()
Dim arr
Dim brr()
arr = Range("k1:k" & Range("k65536").End(3).Row)
ReDim brr(1 To UBound(arr), 1 To 1)
For i = 1 To UBound(arr)
    Select Case Left(arr(i, 1), 1)
        Case "A"
            brr(i, 1) = "双喜五叶神"
        Case "B"
            brr(i, 1) = "黄鹤楼香烟"
        Case "C"
            brr(i, 1) = "长白山香烟"
        Case "D"
            brr(i, 1) = "芙蓉王香烟"
        Case "E"
            brr(i, 1) = "七匹狼香烟"
        Case "F"
            brr(i, 1) = "大中华香烟"
    End Select
Next
Range("b1").Resize(UBound(arr), 1) = brr
End Sub

最佳答案

月排行榜 / 总排行榜

yyyydddd8888

2013-12-30 12:56

fcdd 发表于 2013-12-30 12:09
大虾，小弟再打扰你一次，，再追加一个问题。
非数据指定的，，全部统一显示“其他”

请测试：
(, 下载次数: 3)

上传

点击文件名下载附件

跳转到最佳答案楼层

冥王

1.         Case "A"
   
2.             brr(i, 1) = sheets(2).cells(2,1)  'sheet2第2行第1列单元格，下面一样的改法
   
3.         Case "B"
   
4.             brr(i, 1) = sheets(2).cells(3,1)
   
5.         Case "C"
   
6.             brr(i, 1) = sheets(2).cells(4,1)
   
7.         Case "D"
   
8.             brr(i, 1) = sheets(2).cells(5,1)
   
9.         Case "E"
   
10.             brr(i, 1) = sheets(2).cells(6,1)
    
11.         Case "F"
    
12.             brr(i, 1) =sheets(2).cells(7,1)

复制代码

yyyydddd8888

这样：
根据内容，自动添加自定内容.zip (16.3 KB, 下载次数: 1)

2013-12-28 09:43 上传

点击文件名下载附件

1. Private Sub CommandButton1_Click()
   
2. Dim arr, crr, i&, j&, k&
   
3. Dim brr()
   
4. arr = Sheets(1).Range("k1:k" & Sheets(1).Range("k65536").End(3).Row)
   
5. crr = Sheets(2).Range("a1:b" & Sheets(2).Range("b" & Rows.Count).End(3).Row)
   
6. ReDim brr(1 To UBound(arr), 1 To 1)
   
7. For i = 1 To UBound(arr)
   
8.     For j = 1 To UBound(crr)
   
9.           If Left(arr(i, 1), 1) = crr(j, 2) Then
   
10.              k = k + 1
    
11.              brr(k, 1) = crr(j, 1)
    
12.              Exit For
    
13.           End If
    
14.     Next j
    
15. Next i
    
16. Range("b1").Resize(UBound(arr) + 10, 1) = ""
    
17. Range("b1").Resize(UBound(arr), 1) = brr
    
18. End Sub
    

复制代码

fcdd

冥王 发表于 2013-12-28 09:28

谢谢你的帮忙，，，
你的代码跟我的代码一样，方式不同而已。。。
我真正意思想，，直接在表2 添加或减少，不需要修改代码这么麻烦

fcdd

冥王 发表于 2013-12-28 09:28

其实我自己有个构思
Case "A"。。。把A改为B列
            brr(i, 1) = "双喜五叶神"。。。把显示内容改为A列
但是本人对这知识还处于文盲阶段。。。

fcdd

yyyydddd8888 发表于 2013-12-28 09:42
这样：

大虾可以再请你修改一下
字母不分大小写···

fffox

fcdd 发表于 2013-12-28 11:38
大虾可以再请你修改一下
字母不分大小写···

看看这个

1. 
   
2. Private Sub CommandButton1_Click()
   
3.     Dim arr, brr() As String, d
   
4.     Dim i&, j%
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     arr = Sheets(2).Range("a2").CurrentRegion.Value
   
7.     For i = 1 To UBound(arr)
   
8.         d(arr(i, 2)) = arr(i, 1)
   
9.     Next
   
10.     With Sheets(1)
    
11.         arr = .Range("K1", .Cells(Rows.Count, "k").End(3)).Value
    
12.         ReDim brr(1 To UBound(arr), 1 To 1) As String
    
13.         For i = 1 To UBound(arr)
    
14.             brr(i, 1) = d(Left(arr(i, 1), 1))
    
15.         Next
    
16.         .Range("b1").Resize(Rows.Count).ClearContents
    
17.         .Range("b1").Resize(UBound(arr)) = brr
    
18.     End With
    
19. End Sub
    

复制代码

yyyydddd8888

fcdd 发表于 2013-12-28 11:38
大虾可以再请你修改一下
字母不分大小写···

那很容易：

根据内容，自动添加自定内容.zip (16.65 KB, 下载次数: 1)

2013-12-28 19:40 上传

点击文件名下载附件

1. Private Sub CommandButton1_Click()
   
2. Dim arr, crr, i&, j&, k&
   
3. Dim brr()
   
4. arr = Sheets(1).Range("k1:k" & Sheets(1).Range("k65536").End(3).Row)
   
5. crr = Sheets(2).Range("a1:b" & Sheets(2).Range("b" & Rows.Count).End(3).Row)
   
6. ReDim brr(1 To UBound(arr), 1 To 1)
   
7. For i = 1 To UBound(arr)
   
8.     For j = 1 To UBound(crr)
   
9.           If UCase(Left(arr(i, 1), 1)) = UCase(crr(j, 2)) Then
   
10.              k = k + 1
    
11.              brr(k, 1) = crr(j, 1)
    
12.              Exit For
    
13.           End If
    
14.     Next j
    
15. Next i
    
16. Range("b1").Resize(UBound(arr) + 10, 1) = ""
    
17. Range("b1").Resize(UBound(arr), 1) = brr
    
18. End Sub
    

复制代码

fcdd

yyyydddd8888 发表于 2013-12-28 19:39
那很容易：

大虾，小弟再打扰你一次，，再追加一个问题。
非数据指定的，，全部统一显示“其他”

fcdd

fffox 发表于 2013-12-28 18:12
看看这个

大哥你的代码运行不了···