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

№▁▃风筝﹋

1. myCell.Interior.Color = Application.WorksheetFunction.RandBetween(0, 16777216)

复制代码

这样设置颜色不会出错吗？怎么我记得color颜色值并不是任何数值都可以的，即使在代码中随机数的范围之内？

lsc900707

xlsx文件批量转换为csv:
Sub lsc()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Dim wb As Workbook
    file = Application.GetOpenFilename(MultiSelect:=True)
    For i = LBound(file) To UBound(file)
        Workbooks.Open Filename:=file(i)
        Set wb = ActiveWorkbook
        Path = wb.Path
        On Error Resume Next
        VBA.MkDir (Path & "\csv")
        With wb
            .SaveAs Path & "\csv\" & Replace(wb.Name, ".xlsx", ".csv"), xlCSV
            .Close True
        End With
    Next
    MsgBox "已转换了" & (i - 1) & "个文档"
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

lsc900707

这个位置留给积分突破5000分纪念：

lsc900707

一次性根据编码更新的内容更新工作薄中多个工作表相同编码的描单价、描述与费率
http://club.excelhome.net/thread-1325960-1-1.html
(出处: ExcelHome技术论坛)

sub lsc()
    Dim i&, j&, arr, d, sht As Worksheet
    Set d = CreateObject("scripting.dictionary")
    With Sheets("要更新的内容")
        r = .Cells(Rows.Count, 1).End(3).Row
        arr = .Range("A1:d" & r)
        For i = 2 To UBound(arr)
            For Each sht In Worksheets
                If sht.Name <> "要更新的内容" Then
                    With sht
                        For j = 2 To .Cells(Rows.Count, 1).End(3).Row
                            If .Cells(j, 1) = arr(i, 1) Then
                                 .Range("A" & j).Resize(1, UBound(arr, 2)) = WorksheetFunction.Index(arr, i)
                            End If
                        Next
                    End With
                End If
            Next
        Next
    End With
End Sub

lsc900707

Sub 打印多个隐藏的工作表()
Dim sht As Worksheet
Dim CurStat As Variant
For Each sht In ActiveWorkbook.Worksheets
     If Not sht.Visible Then
          CurStat = sht.Visible
          sht.Visible = xlSheetVisible
          sht.PrintOut
         sht.Visible = CurStat
   End If
Next
End Sub

lsc900707

如何实现按条件自动隐藏行？
http://club.excelhome.net/thread-1326145-1-1.html
(出处: ExcelHome技术论坛)

Sub 隐藏空表()
     For Each sht In Sheets
         With sht
                If .Name <> "录入数据" And .Name <> "系统参数" Then
                     .Rows.Hidden = False
                     For m = 1 To .UsedRange.Cells(Rows.Count, 3).End(xlUp).Row
                         If .Cells(m, 3) = "隐藏" Or .Cells(m, 4) = "隐藏" Then
                              .Cells(m, 3).EntireRow.Hidden = True
                              .Cells(m, 4).EntireRow.Hidden = True
                         End If
                   Next
               End If
         End With
    Next
    MsgBox "报表已生成"
End Sub
Sub 全部显示()
    For Each sht In Sheets
        With sht
            If .Name <> "录入数据" And .Name <> "系统参数" Then
                .Rows.Hidden = False
            End If
        End With
    Next
End Sub

lsc900707

老师们帮忙看看 自己试着编写了一下 懵逼 就是不行
http://club.excelhome.net/thread-1326188-1-1.html
(出处: ExcelHome技术论坛)

按钮放工作表“1”里：
Sub lsc()
     Dim arr
     arr = Sheets("Sheet2").[a1].CurrentRegion.Value
     For i = 2 To UBound(arr)
         If arr(i, 3) <> 0 Then k = k + 1
         For j = 1 To UBound(arr, 2)
             arr(k, j) = arr(i, j)
        Next
     Next
     [K39:N200].ClearContents
     [K39].Resize(k, UBound(arr, 2)) = arr
End Sub

lsc900707

一个按条件显示隐藏工作表的实例：
如何按条件自动显示或隐藏EXCEL表格
http://club.excelhome.net/thread-1326970-1-1.html
(出处: ExcelHome技术论坛)


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    For i = 3 To Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
        If Cells(i, 1) <> "" And Cells(i, 3) <> "" Then
             For Each sht In Sheets
                   If sht.Name <> "企业所得税年度纳税申报填报表单" Then
                        If Cells(i, 1) = Left(sht.Name, 7) And Cells(i, 3) = "是" Then
                              sht.Visible = -1
                        End If
                       If Cells(i, 1) = Left(sht.Name, 7) And Cells(i, 3) = "否" Then
                            sht.Visible = 2
                       End If
                  End If
             Next
        End If
   Next
End Sub

lsc900707

麻烦修改代码
http://club.excelhome.net/thread-1327448-1-1.html
(出处: ExcelHome技术论坛)


Sub 矩形1_单击()
     a = [v1]: b = [v2]: c = [x1]: d = [x2]
     For j = 2 To 4 Step 2
          For i = 8 To [b65536].End(3).Row - 1
              If Cells(i, j) = a And Cells(i + 1, j) = b And Cells(i, j + 2) = c And Cells(i + 1, j + 2) = d Then
                    Cells(i, j).Interior.ColorIndex = 6
                    Cells(i + 1, j).Interior.ColorIndex = 6
                    Cells(i, j + 2).Interior.ColorIndex = 6
                    Cells(i + 1, j + 2).Interior.ColorIndex = 6
              End If
         Next
    Next
End Sub
Sub 矩形2_单击()
     a = [v1]: b = [v2]: c = [w1]: d = [x2]
     For j = 2 To 4
         For i = 8 To [b65536].End(3).Row - 1
            If Cells(i, j) = a And Cells(i + 1, j) = b And Cells(i, j + 1) = c And Cells(i + 1, j + 2) = d Then
                Cells(i, j).Interior.ColorIndex = 6
                Cells(i + 1, j).Interior.ColorIndex = 6
                Cells(i, j + 1).Interior.ColorIndex = 6
                Cells(i + 1, j + 2).Interior.ColorIndex = 6
            End If
         Next
     Next
End Sub

lsc900707

多条件区域删除重复行
http://club.excelhome.net/thread-1327694-1-1.html
(出处: ExcelHome技术论坛)

Sub lsc()
     Dim d As Object, Rng As Range
     Set d = CreateObject("scripting.dictionary")
     With Sheet1
         arr = .[a1].CurrentRegion
         For i = 2 To UBound(arr)
             s = arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4) & "," & arr(i, 5) _
             & "," & arr(i, 6) & "," & arr(i, 7) & "," & arr(i, 8) & "," & arr(i, 9) & "," & arr(i, 10)
             If Not d.exists(s) Then
                 d(s) = ""
             Else
                 If Rng Is Nothing Then
                     Set Rng = .Rows(i)
                 Else
                     Set Rng = Union(Rng, .Rows(i))
                 End If
             End If
         Next
         If Not Rng Is Nothing Then Rng.Delete
     End With
End Sub