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

lsc900707

筛选非空的单元格，然后输出为单独的EXCEL文件，感谢大神
http://club.excelhome.net/thread-1329275-1-1.html
(出处: ExcelHome技术论坛)
代码已更改，请再测试效果吧：
Private Sub CommandButton1_Click()
      Dim tim1 As Date, tim2 As Date: tim1 = Timer
      Dim arr, d As Object, sh As Worksheet
      Application.ScreenUpdating = False
      Application.DisplayAlerts = False
      Set d = CreateObject("scripting.dictionary")
      arr = Range("a1:c" & Cells(Rows.Count, 1).End(xlUp).Row)
      For i = 2 To UBound(arr)
          If Cells(i, 2) <> "" Then
              If Not d.exists(arr(i, 1)) Then
                  Set d(arr(i, 1)) = Range("a" & i).Resize(1, 3)
              Else
                  Set d(arr(i, 1)) = Union(d(arr(i, 1)), Range("a" & i).Resize(1, 3))
              End If
          End If
      Next
      x = d.keys
      For k = 0 To UBound(x)
          Set sh = ActiveWorkbook.Sheets.Add(, after:=ActiveSheet)
          sh.Name = x(k)
          d.items()(k).Copy sh.Range("a" & 2)
          Rows("1:1").Copy sh.Range("a1")
          sh.Cells.EntireColumn.AutoFit
      Next
      For Each sh In Worksheets
          If sh.Name <> "Sheet1" Then
              m = m + 1
              If m = 1 Then sh.Select Else sh.Select False
          End If
      Next
      ActiveWindow.SelectedSheets.Move
      ActiveWorkbook.Close True, ThisWorkbook.Path & "\拆分后的表"
      Sheets("Sheet1").Select
      Application.ScreenUpdating = True
      tim2 = Timer
      MsgBox Format(tim2 - tim1, "拆分完成，共耗时：0.00秒"), 64, "时间统计"
End Sub

lsc900707

http://club.excelhome.net/forum. ... 822&pid=9000011

Sub lsc()
    Dim tim1 As Date, tim2 As Date: tim1 = Timer
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    Dim wb, mypath, myfile
    mypath = ThisWorkbook.Path & "\提取汇总\"
    myfile = Dir(mypath & "*.xls*")
    Do While myfile <> ""
       Set wb = GetObject(mypath & myfile)
       With wb.Sheets("1桩施记")
           .Rows("1:" & .[a65536].End(xlUp).Row).Copy
           Sheets(1).Rows([a65536].End(xlUp).Row + 1).Select
           Selection.PasteSpecial Paste:=xlPasteColumnWidths
           Selection.PasteSpecial Paste:=xlPasteValues
           Selection.PasteSpecial Paste:=xlPasteFormats
      End With
      wb.Close
      myfile = Dir
    Loop
    Set wb = Nothing
    Sheets(1).Rows(1).Delete
    Application.ScreenUpdating = True: Application.DisplayAlerts = True
    tim2 = Timer
    MsgBox Format(tim2 - tim1, "合并完成，耗时：0.00秒"), 64, "温馨提示"
End Sub

lsc900707

去除时间格式中的日期
http://club.excelhome.net/thread-1329056-1-1.html
(出处: ExcelHome技术论坛)
Sub asds()
    For i = 3 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        If Cells(i, 1) <> "" And Cells(i, 2) <> "" Then
           Cells(i, 4) = Format(Cells(i, 1), "hh:mm")
           Cells(i, 5) = Format(Cells(i, 2), "hh:mm")
        End If
    Next
End Sub

lsc900707

请求帮忙！！
http://club.excelhome.net/thread-1330535-1-1.html
(出处: ExcelHome技术论坛)
Private Sub CommandButton1_Click()
    Dim arr, brr(1 To 10000, 1 To 5), w$
    Dim x%, i%, n%, j%
    Dim c As Range
    If ComboBox1.Value = "" Then
        MsgBox "输入错误或空值"
        Exit Sub
    End If
    w = ComboBox1.Value
    With Sheet1
        Set c = .Range("b:b").Find(w, , , xlWhole, , xlPrevious)
        If c Is Nothing Then
            MsgBox "查询人员不存在！"
            ComboBox1.Value = ""
            Exit Sub
        End If
        arr = .Range("a2:i" & .Range("a65536").End(xlUp).Row)
    End With
    For i = 1 To UBound(arr)
        If arr(i, 2) = w Then
            n = n + 1
            brr(n, 1) = arr(i, 1): brr(n, 2) = arr(i, 2): brr(n, 3) = arr(i, 3)
            brr(n, 4) = arr(i, 6): brr(n, 5) = arr(i, 9)
        End If
    Next
    With Sheet3
       .Range("a2:e1000") = ""
       .Range("a2").Resize(n, 5) = brr
    End With
    Sheet3.Activate
    UserForm2.Hide
End Sub

lsc900707

又一个跨工作表复制数据的问题：
跨工作表提取数据
http://club.excelhome.net/thread-1331561-1-1.html
(出处: ExcelHome技术论坛)

Sub lsc()
     Dim arr
     arr = Sheets("Sheet2").[r2].CurrentRegion.Value
     For i = 1 To UBound(arr)
         If arr(i, 1) <> 0 Then k = k + 1
         For j = 1 To UBound(arr, 2)
             arr(k, j) = arr(i, j)
        Next
     Next
     [a26:c5000].ClearContents
     [a26].Resize(k, UBound(arr, 2)) = arr
End Sub

lsc900707

工作表拆分
http://club.excelhome.net/thread-1332019-1-1.html
(出处: ExcelHome技术论坛)

Sub lsc()
    Dim wbk As Workbook
    Application.ScreenUpdating = False
    With Sheet1
        For i = 1 To .Cells(.Rows.Count, 1).End(3).Row Step 20000
            k = k + 1
            Set wbk = Workbooks.Add
            .Rows(i).Resize(20000).Copy wbk.Sheets(1).[a1]
            wbk.Close True, ThisWorkbook.Path & "\" & k
        Next
    End With
    Set wbk = Nothing
    Application.ScreenUpdating = True
End Sub

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

工作表结构相同的多工作薄能合并成一个工作薄文件吗
http://club.excelhome.net/thread-1331544-1-1.html
(出处: ExcelHome技术论坛)
Sub lsc()
Dim myPath$, MyName$, sh As Worksheet, t#
Dim Arr, brr, i&, j&, m&, n&
t = Timer
myPath = ThisWorkbook.Path & "\"
MyName = Dir(myPath & "*.xls*")
Application.ScreenUpdating = False
ReDim brr(1 To 100000, 1 To 8)
Do While MyName <> ""
    If MyName <> ThisWorkbook.Name Then
        n = n + 1
       Set sh = GetObject(myPath & MyName).Sheets("Sheet1")
              Arr = sh.[A1].CurrentRegion
              Workbooks(MyName).Close False
              For i = 4 To UBound(Arr)
                   m = m + 1
                   For j = 1 To 8
                        brr(m, j) = Arr(i, j)
                    Next
              Next
      End If
      MyName = Dir
Loop
Set sh = Nothing
With Sheet1
     .Rows("4:10000").ClearContents
     .[a4].Resize(m, UBound(brr, 2)).Value = brr
End With
Application.ScreenUpdating = True
MsgBox "汇总完成！汇总了：" & n & "个工作表；共有：" & m & "行数据。" & vbCr & "用时：" & Format(Timer - t, "0.00") & "秒", vbInformation
End Sub

chengshanming

不错的分享，顶一个！

blackttea1

不错的分享！