见证成长历程---我的答疑解难代码汇总

lsc900707

筛选数据到指定的工作表中：
Sub lsc()
    Sheets("CNA").UsedRange.ClearContents: Sheets("CNB").UsedRange.ClearContents
    Dim arr, brr, crr
    arr = Sheets("Summary").UsedRange
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
    For i = 2 To UBound(arr)
        If arr(i, 1) Like "CNA*" Then
            m = m + 1: brr(m, 1) = arr(i, 1): brr(m, 2) = arr(i, 2)
        End If
        If arr(i, 1) Like "CNB*" Then
            n = n + 1: crr(n, 1) = arr(i, 1): crr(n, 2) = arr(i, 2)
        End If
    Next
    Sheets("CNA").[A2].Resize(m, UBound(arr, 2)) = brr
    Sheets("CNB").[A2].Resize(n, UBound(arr, 2)) = crr
End Sub

lsc900707

跨表复制指定区域的最后20行数据：
代码放sheet1代码区：
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim i
    i = Sheet1.[b65536].End(3).Row
   If Sheet2.[b3] = "" Then
        Sheet1.Range(Sheet1.Cells(i - 19, 2), Sheet1.Cells(i, 2)).Copy Sheet2.[b3]
        Sheet1.Range(Sheet1.Cells(i - 19, 9), Sheet1.Cells(i, 19)).Copy Sheet2.[c3]
   Else
        Exit Sub
   End If
End Sub

lsc900707

三种方法修改符合条件的单元格数据：
1、
Sub lsc()
    Dim arr
    arr = Sheet1.UsedRange
    For i = 2 To UBound(arr)
        If Cells(i, 2) = [h1] Then Cells(i, 4) = "8888888888"
    Next
End Sub
2、也可用工作表事件修改：
Private Sub Worksheet_Change(ByVal Target As Range)
     Dim r&
     r = Target.Row
     If r > 1 And Target.Column = 2 Then
         If Cells(r, 2) = [h1] Then
             Cells(r, 4) = "8888888888"
         End If
     End If
End Sub
3、
Sub lsc()
Dim s As String
s = InputBox("请输入姓名:", "获取信息")
For Each Rng In Range("b2:b200")
     If Rng.Value = s Then Rng.Offset(, 2) = "8888888888"
Next
End Sub

lsc900707

升级“侠圣”纪念：
        293天，感觉自己是速成的。等级虽然上来了，但知识、能力、水平还是一只小菜鸟。继续努力向大家学习，争取更大进步！

lsc900707

第一次用数组写一个简单的分列代码：
Sub lsc()
    Dim arr, brr, i&
    arr = Range("A1").CurrentRegion
    ReDim brr(1 To UBound(arr), 1 To 4)
        For i = 2 To UBound(arr)
            brr(i, 2) = Right(arr(i, 1), 4)
            brr(i, 1) = Replace(arr(i, 1), brr(i, 2), "")
            brr(i, 4) = Right(arr(i, 1), 3)
            brr(i, 3) = Replace(arr(i, 1), brr(i, 4), "")
        Next
    [b1].Resize(i, 4) = brr
End Sub

lsc900707

用字典数组代替vlookup功能：
Sub lsc()
Dim Arr, i&, d, Brr
Set d = CreateObject("Scripting.Dictionary")
[o3:o50000].ClearContents
Arr = Sheet2.[a1].CurrentRegion
For i = 2 To UBound(Arr)
    d(Arr(i, 2)) = Arr(i, 3)
Next
Brr = [a1].CurrentRegion
For i = 3 To UBound(Brr)
    If d.exists(Brr(i, 5)) Then Cells(i, 15) = d(Brr(i, 5))
Next
End Sub

lsc900707

如何修改代码实现选择文字显示数字？
http://club.excelhome.net/thread-1323039-1-1.html
(出处: ExcelHome技术论坛)


设置不同的数据有效性并按要求显示：
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Str
If Target.Row < 4 Or Target.Column > 13 Then
Exit Sub
Else
Str = Target.Value
Target.Value = Left(Str, 1)
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column <> 8 Or Target.Column <> 12 Or Target.Column <> 13 Then
Target.Validation.Delete
End If
If Target.Row > 4 And Target.Column = 8 Then
Target.Validation.Add xlValidateList, , , "1.国有,2.集体,3.个体,4.其他,"
ElseIf Target.Row > 4 And Target.Column = 12 Then
Target.Validation.Add xlValidateList, , , "1.水田,2.草地,3.林地,"
ElseIf Target.Row > 4 And Target.Column = 13 Then
Target.Validation.Add xlValidateList, , , "1.左,2.右,3.前,4.后,5.上,6.下"
End If
End Sub

lsc900707

如何批量查找逻辑错误值？
http://club.excelhome.net/thread-1323047-1-1.html
(出处: ExcelHome技术论坛)

Sub lsc()
   ActiveSheet.Cells.Interior.ColorIndex = 0
   arr = ActiveSheet.[b3].CurrentRegion
   For i = 4 To UBound(arr)
       If Cells(i, 12) = 100 Or Cells(i, 12) = 110 Or Cells(i, 12) = 120 Or Cells(i, 12) = 130 Then
            If Cells(i, 18) = "" Or Cells(i, 21) = "" Or Cells(i, 22) = "" Or Cells(i, 23) = "" Then
                Union(Cells(i, 18), Cells(i, 21), Cells(i, 22), Cells(i, 23)).Interior.ColorIndex = 3
            End If
        End If
        If Cells(i, 13) = 43 Or Cells(i, 13) = 44 Then
            If IsNumeric(Cells(i, 15)) Then
                Cells(i, 15).Interior.ColorIndex = 3
            End If
        End If
    Next
    MsgBox "R、U、V、W列有单元格为空，请核对！"
    MsgBox "O列单元格有数字，请修改！"
End Sub

lsc900707

把身份证号码按姓名导到没有身份证号码的那个表！
http://club.excelhome.net/thread-1322904-1-1.html
(出处: ExcelHome技术论坛)

Sub lsc()
Dim Arr, i&, d, Brr
Columns("O").NumberFormatLocal = "@"
Set d = CreateObject("Scripting.Dictionary")
[o3:o50000].ClearContents
Arr = Sheet2.[a1].CurrentRegion
For i = 2 To UBound(Arr)
d(Arr(i, 2)) = Arr(i, 3)
Next
Brr = [a1].CurrentRegion
For i = 3 To UBound(Brr)
If d.exists(Brr(i, 5)) Then Cells(i, 15) = d(Brr(i, 5))
Next
End Sub

weiyingde

lsc900707 发表于 2017-1-10 21:41
把身份证号码按姓名导到没有身份证号码的那个表！
http://club.excelhome.net/thread-1322904-1-1.html
( ...

祝贺，继续前进。
反观我自己，汗颜。