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

lsc900707

谢谢大家的支持和鼓励。如果能给大家一丁点儿的启发和帮助，我也会很欣慰的。

chxw68

lsc900707 发表于 2017-1-7 19:16
升级“侠圣”纪念：
        293天，感觉自己是速成的。等级虽然上来了，但知识、能力、水平还是一只小菜 ...

10个月时间能达到如此水平，令人敬佩！

lsc900707

chxw68 发表于 2017-3-6 09:58
10个月时间能达到如此水平，令人敬佩！

多谢褚老师的褒奖和鼓励。学生永远向你学习!

chxw68

lsc900707 发表于 2017-3-6 10:03
多谢褚老师的褒奖和鼓励。学生永远向你学习!

惭愧！我来论坛已经10年多了，你来论坛才10个月，如果我有你的学习精神和能力，水平恐不止于此。

lsc900707

本月二十号就一周年了，近期学习很少，上网也不多了，但一直看到您在忙着指导大家，钦佩，仰慕褚老师。

lsc900707

使用VBA给EXCEL处理数据
http://club.excelhome.net/thread-1331675-1-1.html
(出处: ExcelHome技术论坛)
Private Sub CommandButton1_Click()
    Dim tim1 As Date, tim2 As Date: tim1 = Timer
    Dim arr, d As Object, sht As Worksheet
    Set d = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    For i = 1 To UBound(arr)
        If Not d.exists(arr(i, 1)) Then
            Set d(arr(i, 1)) = Range("a" & i).Resize(1, 94)
        Else
            Set d(arr(i, 1)) = Union(d(arr(i, 1)), Range("a" & i).Resize(1, 94))
        End If
    Next
    x = d.keys
    For k = 1 To UBound(x)
        Set sht = ActiveWorkbook.Sheets.Add(, after:=ActiveSheet)
        sht.Name = x(k)
        d.items()(k).Copy sht.Range("a" & 2)
        Rows("1:1").Copy sht.[a1]
    Next
    For Each sht In Sheets
        If sht.Name <> "Sheet1" Then
           With sht
              k = .Cells(.Rows.Count, 1).End(xlUp).Row
              arr = .[a1].CurrentRegion
              For i = 2 To UBound(arr)
                  For j = 6 To UBound(arr, 2)
                     If IsNumeric(.Cells(i, j)) Then
                         .Cells(k + 1, j) = Application.Average(Application.Index(arr, , j))
                     End If
                  Next
              Next
            End With
        End If
    Next
    tim2 = Timer
    MsgBox Format(tim2 - tim1, "拆分完成，共耗时：0.00秒"), 64, "时间统计"
End Sub

jiminyanyan

lsc900707 发表于 2017-3-6 10:15
本月二十号就一周年了，近期学习很少，上网也不多了，但一直看到您在忙着指导大家，钦佩，仰慕褚老师。

厉害，一年就达到如此水平。

lsc900707

jiminyanyan 发表于 2017-3-6 21:55
厉害，一年就达到如此水平。

说实话，很多时候我是靠度娘帮我。谢谢你的激励！

lsc900707

求助如何编制一个宏，将附件Sheet1中“Y”列和“Z”列中小于0的所有数据信息，分别...
http://club.excelhome.net/thread-1332145-1-1.html
(出处: ExcelHome技术论坛)
代码放模块中，按钮放sheet2：
Sub lsc()
    [a9:z5000].ClearContents
    Dim arr, brr
    arr = Sheets("sheet1").UsedRange
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    For i = 9 To UBound(arr)
        If arr(i, 25) < 0 Or arr(i, 26) < 0 Then
            m = m + 1
            For j = 1 To UBound(arr, 2)
                 brr(m, j) = arr(i, j)
            Next
        End If
    Next
    [A9].Resize(m, UBound(arr, 2)) = brr
End Sub

lsc900707

按班级导出的xls文件能保持原文件的列宽格式吗？敬请老师们赐教。
http://club.excelhome.net/thread-1332550-1-1.html
(出处: ExcelHome技术论坛)
将原代码稍作修改即可满足要求：
Sub 按班保存为工作簿()
    Dim wb As Workbook, arr, rng As Range, d As Object, k, t, sh As Worksheet, i&
    Set rng = Range("A1:x3")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    arr = Range("a1:x" & Range("a65536").End(xlUp).Row)
    Set d = CreateObject("scripting.dictionary")
    For i = 4 To UBound(arr)
         If Not d.exists(arr(i, 1)) Then
                Set d(arr(i, 1)) = Cells(i, 1).Resize(1, 24)
            Else
                Set d(arr(i, 1)) = Union(d(arr(i, 1)), Cells(i, 1).Resize(1, 24))
         End If
    Next
    k = d.keys
    t = d.items
    For i = 0 To d.Count - 1
        Set wb = Workbooks.Add(xlWBATWorksheet)
        With wb.Sheets(1)
            rng.Copy .[A1]: t(i).Copy .[A4]
            For j = 1 To UBound(arr, 2)
               .Columns(j).ColumnWidth = ThisWorkbook.ActiveSheet.Columns(j).ColumnWidth
            Next
        End With
        wb.SaveAs Filename:=ThisWorkbook.Path & "\各班成绩文件\" & Mid(Range("f1"), 5, 7) & k(i) & "班成绩", FileFormat:=xlExcel8
        wb.Close
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "完毕"
End Sub