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

lsc900707

有网友qq发帖求助，35个工作簿批量增加一列“发布日期”，回复如下：
Sub lsc()
Application.ScreenUpdating = False
Dim wb As Excel.Workbook
x = ThisWorkbook.Path
f = Dir(x & "\" & "*xls")
Do While f <> ""
If f <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(x & "\" & f)
    r = wb.Worksheets("sheet1").[a65536].End(3).Row
    s = wb.Worksheets("sheet1").UsedRange.SpecialCells(xlCellTypeLastCell).Column
    wb.Worksheets("sheet1").Cells(3, s + 1) = "发布日期"
    wb.Worksheets("sheet1").Range(Cells(4, s + 1), Cells(r, s + 1)).Value = "2014/8/23"
    wb.Save
    wb.Close
    End If
    f = Dir
    Loop
Application.ScreenUpdating = True
End Sub

lsc900707

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Sheets("股室").[b3].AutoFilter Field:=2, Criteria1:=Target.Text
End Sub
（附件上传失败，待后补传）

lsc900707

指定区域 A1:A100 随机填色代码：
Sub lsc()
ActiveSheet.Range("a:a").Interior.ColorIndex = 2
Dim myRange, myCell  As Range
Set myRange = Range("A1:A100")
For Each myCell In myRange
myCell.Interior.Color = Application.WorksheetFunction.RandBetween(0, 16777216)
Next
End Sub

lsc900707

按指定编号筛选数据代码：
Sub lsc()
    [e2:g5000].ClearContents
    Dim d, arr, brr
    Set d = CreateObject("scripting.dictionary")
    arr = Range("d1:d" & [d65536].End(3).Row)
    For i = 2 To UBound(arr)
        d(arr(i, 1)) = ""
    Next
    arr = [a1].CurrentRegion
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    For i = 1 To UBound(arr)
        If d.exists(arr(i, 1)) Then
            k = k + 1
            brr(k, 1) = arr(i, 1): brr(k, 2) = arr(i, 2): brr(k, 3) = arr(i, 3)
        End If
    Next
    [e2].Resize(k, UBound(brr, 2)) = brr
End Sub

lsc900707

统计指定区域内字符出现的个（次）数：
Sub lsc()
Dim d As Object, arr
Set d = CreateObject("Scripting.Dictionary")
arr = Application.InputBox("请选择要统计的区域：", , , , , , , 8)
For i = 1 To UBound(arr, 2)
     For j = 1 To UBound(arr)
         If arr(j, i) <> "" Then d(arr(j, i)) = d(arr(j, i)) + 1
     Next j
Next i
k = d.keys
t = d.items
[S1] = "显示结果": [T1] = "出现次数"
Columns("S").NumberFormatLocal = "@"
[S2].Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(k)
[T2].Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(t)
End Sub

lsc900707

删除A列中开始字母不为“B”的数据行：
Sub lsc()
    For i = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
        If Not Cells(i, 1) Like "B*" Then Rows(i).Delete
    Next
End Sub

lsc900707

以下代码为条件合并多表数据：
Sub lsc()
ActiveSheet.UsedRange.ClearContents
Dim arr, brr(1 To 2000, 1 To 4)
For Each sh In Worksheets
    If sh.Name <> "汇总" Then
        arr = sh.UsedRange
        For i = 7 To UBound(arr)
            If arr(i, 3) <> "" Then
                j = j + 1
                brr(j, 1) = arr(3, 2)
                brr(j, 2) = arr(3, 4)
                brr(j, 3) = arr(i, 3)
                brr(j, 4) = arr(i, 8)
            End If
        Next
    End If
Next
With Sheets("汇总")
     .Columns(3).NumberFormatLocal = "@"
    .[a1:d1] = Array("订单号", "超市", "条码", "细数")
    .[a2].Resize(j, 4) = brr
End With
End Sub

lsc900707

向指定表拷贝固定区域的数据：
Sub lsc()
    For Each sht In Worksheets(Array("电位1", "电位2", "电位3"))
         ActiveSheet.[o8:q9000].Copy sht.[o8]
    Next
End Sub

lsc900707

同一工作簿指定表合并代码的几种写法：
1、Sub 工作表汇总()
    ActiveSheet.UsedRange.Offset(1, 0).ClearContents
    For Each st In Worksheets(Array("数据1", "数据2", "数据3"))
        st.UsedRange.Offset(1, 0).Copy [a65536].End(xlUp).Offset(1, 0)
    Next
End Sub
2、Sub 工作表汇总()
ActiveSheet.UsedRange.Offset(1, 0).ClearContents
For Each st In Worksheets
If st.Name Like "数据*" Then st.UsedRange.Offset(1, 0).Copy [a65536].End(xlUp).Offset(1, 0)
Next
End Sub
3、Sub 工作表汇总()
Application.ScreenUpdating = False
Sheets("数据源").Range("2:65536").ClearContents
For Each st In Worksheets
If st.Name <> ActiveSheet.Name And st.Name <> "预估收入计算表" Then st.UsedRange.Offset(1, 0).Copy [a65536].End(xlUp).Offset(1, 0)
Next
Application.ScreenUpdating = True
End Sub

lsc900707

合并多表指定的D列内容到汇总表：
Sub lsc()
    Columns("C:Q").ClearContents
    Dim sht As Worksheet
    For Each sht In Sheets
        If sht.Name <> ActiveSheet.Name Then
            With sht
                r = .[a65536].End(3).Row
                .Range("D2").Resize(r).Copy ActiveSheet.Cells(2, 3 + n)
                ActiveSheet.Cells(1, 3 + n) = sht.Name
                n = n + 1
            End With
        End If
    Next
End Sub