Excel VB简单操作

Alt + F11 进入宏编辑界面
========================================
' 当前宏对excel的操作与excel的事件冲突时
Application.EnableEvents = False
' Your Code'
Application.EnableEvents = True
=========================================
' 禁止删除行

Application.CommandBars("Cell").Controls(6).Enabled = False
Application.CommandBars("Row").Controls(6).Enabled = False

=========================================
' 要实现的功能：
' 针对一个单元格实现自加，即输入新数值+原单元格的数值
' 以此可以延伸其他功能
Dim x, y
 
' 选中的单元格内容改变时会触发该事件
' 改变后的值
Private Sub Worksheet_Change(ByVal Target As Range)
  x = Target.Value
  Application.EnableEvents = False '屏蔽掉Excel事件，否则对target.value赋值时会触发该事件
  Target.Value = x + y
  Application.EnableEvents = True ' 解除屏蔽
End Sub
 
' 鼠标点击不同单元格时会触发该事件
' 改前的值
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  y = Target.Value
End Sub

==========================================

Sub 隐藏空列()
  a = Worksheets(ActiveSheet.Name).UsedRange.Rows.Count   ' 判断总行数
  Dim begin_row%, begin_col%, last_col
  begin_row = Selection.Cells(1, 1).Row                  ' 得到左上角第一个格所在的行
  begin_col = Selection.Cells(1, 1).Column               ' 得到左上角第一个格所在的列
  last_col = ActiveCell.SpecialCells(xlCellTypeLastCell).Column   ' 最后一个单元格所在的列数
  all_null_row = a - begin_row + 1    ' 如果该列数据区都为空, 应该有多少行
  For i = 1 To last_col           ' 第一列到最后一列循环
     null_row = Application.WorksheetFunction.CountBlank(Range(Cells(begin_row, i), Cells(a, i)))
     If null_row = all_null_row Then
         Columns(i).Select
         Selection.EntireColumn.Hidden = True
     End If
  Next
End Sub

Sub 显示隐藏()
a = Worksheets(ActiveSheet.Name).UsedRange.Rows.Count   ' 判断总行数
Dim begin_row%, begin_col%, last_col
begin_row = Selection.Cells(1, 1).Row                  ' 得到左上角第一个格所在的行
begin_col = Selection.Cells(1, 1).Column               ' 得到左上角第一个格所在的列
last_col = ActiveCell.SpecialCells(xlCellTypeLastCell).Column   ' 最后一个单元格所在的列数
all_null_row = a - begin_row + 1    ' 如果该列数据区都为空, 应该有多少行
    For i = 1 To last_col           ' 第一列到最后一列循环
         Columns(i).Select
        If Selection.EntireColumn.Hidden = True Then
          Selection.EntireColumn.Hidden = False
        End If
    Next
End Sub

=================================================================
' 逐个替换
' =SUM(A1:A10) => =SUMIF(A1:A10,"<0",A1:A10)+SUMIF(A1:A10,">0",A1:A10)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim formula As String
  Dim neFormula As String
  Dim tmp As String
  
  formula = Target.formula
  If (Left(LCase(formula), 5) = "=sum(") Then
    tmp = Replace(formula, "=SUM(", "")
    tmp = Replace(tmp, "=sum(", "")
    tmp = Replace(tmp, ")", "")
    '  Chr(34)  双引号
    ' vbCrLf 换行符
    new_formula = "=SUMIF(" & tmp & "," & Chr(34) & ">0" & Chr(34) & "," & tmp & ")+SUMIF(" & tmp & "," & Chr(34) & "<0" & Chr(34) & "," & tmp & ")"
    
    Application.EnableEvents = False
    Target.formula = new_formula
    Application.EnableEvents = True
    
    MsgBox formula & vbCrLf & "=>" & vbCrLf & new_formula
  End If
End Sub

' 加强版，直接自动匹配所在行所有单元格
' =SUM(A1:A10) => =SUMIF(A1:A10,"<0",A1:A10)+SUMIF(A1:A10,">0",A1:A10)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim formula As String
  Dim neFormula As String
  Dim tmp As String
  Dim row As Long
  Dim cols As Long
  Dim col As Integer
  
  Dim count As Integer

  count = 0
  row = Target.row
  
  With ActiveSheet
    cols = .UsedRange.Columns.count
  
    
    For col = 1 To cols
        formula = .Cells(row, col).formula
        If (Left(LCase(formula), 5) = "=sum(") Then
          tmp = Replace(formula, "=SUM(", "")
          tmp = Replace(tmp, "=sum(", "")
          tmp = Replace(tmp, ")", "")
          '  Chr(34)  双引号
          ' vbCrLf 换行符
          new_formula = "=SUMIF(" & tmp & "," & Chr(34) & ">0" & Chr(34) & "," & tmp & ")+SUMIF(" & tmp & "," & Chr(34) & "<0" & Chr(34) & "," & tmp & ")"
          
          Application.EnableEvents = False
          .Cells(row, col).formula = new_formula
          Application.EnableEvents = True
          
          count = count + 1
          
          'MsgBox formula & vbCrLf & "=>" & vbCrLf & new_formula
        End If
    Next col
    MsgBox count
  End With
End Sub

' 加强版，直接自动匹配所在行所有单元格
' =SUM(A1:A10) => =SUMIF(A1:A10,"<0",A1:A10)+SUMIF(A1:A10,">0",A1:A10)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim formula As String
  Dim neFormula As String
  Dim tmp As String
  Dim rows As Long
  Dim cols As Long
  Dim i As Integer
  Dim j As Integer
  Dim count As Integer
  Dim l_str As String
  Dim r_str As String
  
  l_str = "=SUM("
  r_str = ")"
 
  count = 0
  With ActiveSheet
    cols = .UsedRange.Columns.count
    rows = .UsedRange.rows.count
    
    For i = 1 To rows
      For j = 1 To cols
            formula = .Cells(i, j).formula
            If (Left(formula, Len(l_str)) = l_str And InStr(formula, ":") > 0) Then
            tmp = Mid(formula, Len(l_str) + 1, Len(formula) - Len(l_str) - Len(r_str))
              '  Chr(34)  双引号
              ' vbCrLf 换行符
              new_formula = "=SUMIF(" & tmp & "," & Chr(34) & ">0" & Chr(34) & "," & tmp & ")+SUMIF(" & tmp & "," & Chr(34) & "<0" & Chr(34) & "," & tmp & ")"
              
              
              If (count = 0) Then
                MsgBox formula & vbCrLf & "=>" & vbCrLf & new_formula
              End If
              
              Application.EnableEvents = False
              .Cells(i, j).formula = new_formula
              Application.EnableEvents = True
              
              count = count + 1
            End If
        Next j
    Next i
    MsgBox count
  End With
End Sub


' 智能加强版，直接自动匹配所在Sheet所有单元格
' =IFERROR(IF(ISERROR(H461/$H$481),"",(H461/$H$481)),0) => IF(ISERROR(IF(ISERROR(H461/$H$481),"",(H461/$H$481))),0,IF(ISERROR(H461/$H$481),"",(H461/$H$481)))
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim formula As String
  Dim tmp As String
  Dim rows As Long
  Dim cols As Long
  Dim count As Integer
  Dim i As Integer
  Dim j As Integer
  Dim l_str As String
  Dim r_str As String
  
  l_str = "=IFERROR("
  r_str = ",0)"
  
  count = 0
  With ActiveSheet
  
    formula = Target.formula
    If (Left(formula, 9) = l_str) Then
          tmp = Mid(formula, Len(l_str) + 1, Len(formula) - Len(l_str) - Len(r_str))
          tmp = "=IF(ISERROR(" & tmp & "),0," & tmp & ")"
      
      MsgBox formula & vbCrLf & "=>" & vbCrLf & tmp
    End If
    
    rows = .UsedRange.rows.count
    cols = .UsedRange.Columns.count
    For i = 1 To rows
        For j = 1 To cols
            formula = .Cells(i, j).formula
            If (Left(formula, 9) = l_str) Then
              tmp = Mid(formula, Len(l_str) + 1, Len(formula) - Len(l_str) - Len(r_str))
              tmp = "=IF(ISERROR(" & tmp & "),0," & tmp & ")"
              
              '  Chr(34)  双引号
              ' vbCrLf 换行符
              
              Application.EnableEvents = False
              .Cells(i, j).formula = tmp
              Application.EnableEvents = True
              
              count = count + 1
              
              'MsgBox formula & vbCrLf & "=>" & vbCrLf & new_formula
            End If
        Next j
    Next i
    MsgBox count
  End With
End Sub


==================================================================

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim id1   As String
    Dim id2   As String
    Dim store As String
    Dim row   As Long
    Dim k     As Integer
    Dim arr
    Dim sheet1 As String
    
    '只监视第六列的数值变化
    If (Target.Column <> 6) Then
        Exit Sub
    End If
        
    sheet1 = "Sheet1"
    id1 = Cells(Target.row, 1).Value    ' 要匹配的店铺ID
    
    With Sheets(sheet1)
        row = .UsedRange.Rows.count
        k = 0
        For i = 2 To row
            If (.Cells(i, 1).Value = id1) Then
                k = i
                Exit For
            End If
        Next i
        
        If (k = 0) Then ' 匹配失败
            MsgBox .row & "-" & .Column & "-" & id1 & "-" & id2
            Exit Sub
        End If
        
        On Error Resume Next
        id2 = Split(Target.Value, "_")(0)   ' 被匹配的店铺ID ' 有些店铺名称为空，此处不要取值
        .Cells(k, 7).Value = id2
        If (Err.Number <> 0) Then
            Exit Sub
        End If
       
        ' 在D列查找str1
        'On Error Resume Next         ' match匹配不到时直接跳过
        'o = Application.WorksheetFunction.Match(id2, Range("C:C"), 0)
        Dim o As Long
        o = 0
        For i = 2 To UsedRange.Rows.count
            If (Cells(i, 3).Value = id2) Then
                o = i
                Exit For
            End If
        Next i
        
        If (o = 0) Then
            MsgBox "Fuck,本地没找到数据，肯定vb代码问题了.." & id2
            Exit Sub
        End If
        
        .Cells(k, 8).Value = Cells(o, 4).Value
        
        ' 匹配的店铺，与被手工搭配的店铺不在一行
        ' 被手工搭配的店铺与匹配店铺的后面的店铺置换
        ' 然后把手工搭配好的那行删除
        Dim temp1 As String
        Dim temp2 As String
        Dim temp3 As String
        temp1 = Cells(o, 3).Value
        temp2 = Cells(o, 4).Value
        temp3 = Cells(o, 5).Value
        
        Cells(o, 3).Value = Cells(Target.row, 3).Value
        Cells(o, 4).Value = Cells(Target.row, 4).Value
        Cells(o, 5).Value = Cells(Target.row, 5).Value
        
        Cells(Target.row, 3).Value = temp1
        Cells(Target.row, 4).Value = temp2
        Cells(Target.row, 5).Value = temp3
        ' Rows(Target.row).Delete
        ' Target.Delete
    End With
End Sub


==================================================================

Sub 匹配数据()
  Dim row As Long
  Dim str1 As String
  Dim str2 As String
  Dim k As Integer
  Dim j As Integer
  Dim sheet1 As String
  Dim sheet2 As String
  
  sheet1 = "Sheet1"
  sheet2 = "Sheet2"
  Application.EnableEvents = False
  
  Sheets(sheet1).Activate
  With ActiveSheet
    row = .UsedRange.Rows.count ' 有数据的行数
    
    .Range("C:C").ClearContents ' 清空C匹配状态
    .Range("F:F").ClearContents ' 清空F匹配状态
    .Range("G:G").ClearContents ' 清空匹配店铺
    .Range("H:H").ClearContents ' 清空匹配店铺
     Columns("C:C").ColumnWidth = 0 '被选择列宽度设置为0相当于隐藏
     Columns("F:F").ColumnWidth = 0 '被选择列宽度设置为0相当于隐藏
    
    For i = 2 To row
      str1 = .Cells(i, 1).Value    '[i,1]单元格的值
      ' 在D列查找str1
      On Error Resume Next         ' match匹配不到时直接跳过
      k = Application.WorksheetFunction.Match("S" & str1, ActiveSheet.Range("D:D"), 0)
      
      If (Err.Number <> 0) Then    '若出错置k=0
        k = 0
      End If
      
      If (k > 0) Then              ' 若k>0表明匹配成功
        .Cells(i, 3).Value = "1"   ' 匹配状态置1
        .Cells(k, 6).Value = "1"   ' 被匹配到时给状态1
        .Cells(i, 7).Value = Cells(k, 4).Value '匹配到的店铺ID放在G列
        .Cells(i, 8).Value = Cells(k, 5).Value '匹配到的店铺名称放在H列
      End If
    Next i
  End With
    
    
  Sheets(sheet2).Activate
  With ActiveSheet
    .Range("A:A").ClearContents ' 清空未匹配店铺ID
    .Range("B:B").ClearContents ' 清空未匹配店铺名称
    .Range("C:C").ClearContents ' 清空未匹配店铺
    .Range("D:D").ClearContents ' 清空未匹配店铺
     .Range("E:E").ClearContents ' 清空未匹配店铺
     Columns("C:C").ColumnWidth = 0 '被选择列宽度设置为0相当于隐藏
     Columns("D:D").ColumnWidth = 0 '被选择列宽度设置为0相当于隐藏
     Columns("E:E").ColumnWidth = 0 '被选择列宽度设置为0相当于隐藏
    .Cells(1, 1).Value = "店铺ID"   '设置标题
    .Cells(1, 2).Value = "店铺名称" '设置标题
    .Cells(1, 5).Value = "选择店铺" '设置标题
    
    row = Sheets(sheet1).UsedRange.Rows.count
    k = 2 ' Sheet2中从第二行起追加未匹配的店铺
    j = 2 ' Sheet2中从第二行起追加被匹配的店铺
    For i = 2 To row  ' 遍历Sheet1中未匹配到的店铺拷贝到Sheet2中
      str1 = Sheets("Sheet1").Cells(i, 3).Value ' 匹配状态
      str2 = Sheets("Sheet1").Cells(i, 6).Value ' 被匹配状态
      
      If (Len(str1) = 0) Then '匹配成功的店铺后面一行有标志位为1，匹配失败的为空
        .Cells(k, 1).Value = Sheets(sheet1).Cells(i, 1).Value
        .Cells(k, 2).Value = Sheets(sheet1).Cells(i, 2).Value
        k = k + 1
      End If
      
      If (Len(str2) = 0) Then
        .Cells(j, 3).Value = Sheets(sheet1).Cells(i, 4).Value
        .Cells(j, 4).Value = Sheets(sheet1).Cells(i, 5).Value
        
        If (Len(.Cells(j, 3).Value) > 0) Then   'Excel是固定行数，需要判断被拼字符串是否为空
          .Cells(j, 5).Value = .Cells(j, 3).Value & "_" & .Cells(j, 4).Value
        End If
        j = j + 1
      End If
      .Cells(i, 6).Value = "" ' 待选择下拉列表选中项置空
    Next i
  End With
  Application.EnableEvents = True
End Sub