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

jjmysjg

要是有实例就更好了

lsc900707

jjmysjg 发表于 2017-2-12 21:34
要是有实例就更好了

感谢你的关注和提醒，但最近上传附件老出错，所以只能尽量链接地址出来。

jjmysjg

lsc900707 发表于 2017-2-12 21:39
感谢你的关注和提醒，但最近上传附件老出错，所以只能尽量链接地址出来。

链接地址也好，谢谢老师！

microyip

这个是上期论坛评核金牌的要求所导致的结果，为了参与下次评核，我猜陆陆续续有这种记录自己出手的记录贴，好啊！一大进步！楼主，努力，下次金牌也将是你的，加油！

lsc900707

不是吧，我只是想集中在一个地方，方便自己查阅。后来版主把它移到了分享板块。谢谢你的鼓励。

lsc900707

如何不用选择性粘贴中的转置面自动取数？
http://club.excelhome.net/thread-1328508-1-1.html
(出处: ExcelHome技术论坛)
把前面的示例数据删除，数据从第一行起：
Sub lsc()
     Dim arr
     arr = Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row)
     j = 1: k = 1
     For i = 1 To UBound(arr)
         If arr(i, 1) <> "" Then
              k = k + 1
              Cells(j, k) = arr(i, 1)
         Else
              j = j + 1: k = 1
         End If
     Next
End Sub

lsc900707

修改VBA语句  关于合并工作表的列数的变动
http://club.excelhome.net/thread-1328390-1-1.html
(出处: ExcelHome技术论坛)
Sub HzWb()
     Dim bt As Range, r As Long
     r = 1
    Dim wt As Worksheet
    Set wt = ThisWorkbook.Worksheets(1)
    wt.Rows(r + 1 & ":1048576").ClearContents
    Application.ScreenUpdating = False
    Dim FileName As String, sht As Worksheet, wb As Workbook
    Dim Erow As Long, fn As String, arr As Variant
    FileName = Dir(ThisWorkbook.Path & "\*.xlsx")
    Do While FileName <> ""
           If FileName <> ThisWorkbook.Name Then
                Erow = wt.Range("A1").CurrentRegion.Rows.Count + 1
                fn = ThisWorkbook.Path & "\" & FileName
               Set wb = GetObject(fn)
               Set sht = wb.Worksheets(1)
              arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(1048576, "J").End(xlUp).Offset(0, 1))
              wt.Cells(Erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
              wb.Close False
          End If
          FileName = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

lsc900707

统计汇总
http://club.excelhome.net/thread-1328599-1-1.html
(出处: ExcelHome技术论坛)
就是简单的去重求和吧：
Sub lsc()
      Dim d, arr
      Set d = CreateObject("scripting.dictionary")
      arr = [a1].CurrentRegion
      For i = 1 To UBound(arr)
           d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
      Next
      [g1:h5000].ClearContents
      [g1].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
End Sub

lsc900707

承包方编码后面保留4位
http://club.excelhome.net/thread-1328585-1-1.html
(出处: ExcelHome技术论坛)
Sub lsc()
      For Each sht In Worksheets
           With sht
                 arr = .Range("a1:a" & .Cells(.Rows.Count, 1).End(xlUp).Row)
                 For i = 5 To UBound(arr)
                      If .Cells(i, 1) <> "" Then
                             .Cells(i, 1) = Right(.Cells(i, 1), 4)
                      End If
                 Next
           End With
      Next
End Sub

lsc900707

求双击单元表格，复制该行第2列内容到其外一单元表格
http://club.excelhome.net/thread-1326530-1-1.html
(出处: ExcelHome技术论坛)
Private Sub Worksheet_BeforeDoubleClick(ByVal T As Range, Cancel As Boolean)
If T.Column = 1 And T.Count = 1 Then
    With Sheets("打印")
       .[b3] = T.Offset(, 1)
       .[d3] = T.Offset(, 2)
       .[b4] = T.Offset(, 5)
       .[b5] = T.Offset(, 4)
       .[b7] = T.Offset(, 7)
    End With
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
    Sheets("来文汇总").Select
End If
End Sub