分享一个，供参考强大的VBA总算完成满足基本需求快表软件

楼主

  Public Sub RangeChanged(sender As Object,e As SpreadsheetGear.Windows.Controls.RangeChangedEventArgs)
'型材部分。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。
      If e.Range.Intersect(Range("F_5212")) IsNot Nothing Then
'填写符合条件后执行的代码
            Dim lastRow As Long
            Dim destCol As Long
            Dim srcCol As Long
            Dim i As Long
            Dim Cells As IRange = ActiveWorkbook.ActiveWorksheet.Cells
            lastRow = Range("F_5245").RowCount + 14
            '循环从第16行开始向下转换数据
            For i = 15 To lastRow
   srcCol = 11 'L列
                  destCol = 6 'G
                  '将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
'《《《《《《《《《《
For i = 15 To lastRow
   srcCol = 15 'L列
                  destCol = 7 'G
                  '将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
'《《《《《《《《《《
For i = 15 To lastRow
   srcCol = 16 'L列
                  destCol = 8 'G
                  '将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
         End If
'玻璃部分........................................................
If e.Range.Intersect(Range("F_5212")) IsNot Nothing Then
'填写符合条件后执行的代码
            Dim lastRow As Long
            Dim destCol As Long
            Dim srcCol As Long
            Dim i As Long
   Dim h As Long
            Dim Cells As IRange = ActiveWorkbook.ActiveWorksheet.Cells


            lastRow = Range("F_5245").RowCount + 28
   h = Range("F_5245").RowCount + 16+1

            For i = h To lastRow
                  srcCol = 15 'L列
   destCol = 4 'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
   For i = h To lastRow
                  srcCol = 16'L列
   destCol = 5'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
   For i = h To lastRow
                  srcCol = 17'L列
   destCol = 6'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
For i = h To lastRow
                  srcCol = 18'L列
   destCol = 7'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
         End If
'开启扇部分.......................................................................
If e.Range.Intersect(Range("F_5212")) IsNot Nothing Then
'填写符合条件后执行的代码
            Dim lastRow As Long
            Dim destCol As Long
            Dim srcCol As Long
            Dim i As Long
   Dim h As Long
            Dim Cells As IRange = ActiveWorkbook.ActiveWorksheet.Cells
            '确定源和目标列

            lastRow = Range("F_5245").RowCount + 21
   h = Range("F_5245").RowCount + 16+1
            '循环从第16行开始向下转换数据
            For i = h To lastRow
                  srcCol = 19 'L列
   destCol = 10 'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
   For i = h To lastRow
                  srcCol = 20'L列
   destCol = 11'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
   For i = h To lastRow
                  srcCol = 21'L列
   destCol = 13'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
For i = h To lastRow
                  srcCol = 23'L列
   destCol = 12'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
   End If
'五金配置部分............................................................
If e.Range.Intersect(Range("F_5212")) IsNot Nothing Then
'填写符合条件后执行的代码
            Dim lastRow As Long
            Dim destCol As Long
            Dim srcCol As Long
            Dim i As Long
   Dim h As Long
            Dim Cells As IRange = ActiveWorkbook.ActiveWorksheet.Cells
            '确定源和目标列

            lastRow = Range("F_5245").RowCount + 35
   h = Range("F_5245").RowCount + 31
            '循环从第16行开始向下转换数据
            For i = h To lastRow
                  srcCol = 16 'L列
   destCol = 4 'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
   For i = h To lastRow
                  srcCol = 15'L列
   destCol = 7'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
   End If
'辅材配置表。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。
If e.Range.Intersect(Range("F_5212")) IsNot Nothing Then
'填写符合条件后执行的代码
            Dim lastRow As Long
            Dim destCol As Long
            Dim srcCol As Long
            Dim i As Long
   Dim h As Long
            Dim Cells As IRange = ActiveWorkbook.ActiveWorksheet.Cells
            '确定源和目标列

            lastRow = Range("F_5245").RowCount + 35
   h = Range("F_5245").RowCount + 24
            '循环从第16行开始向下转换数据
            For i = h To lastRow
                  srcCol = 19 'L列
   destCol = 12 'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
   For i = h To lastRow
                  srcCol = 20'L列
   destCol = 13'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
   End If

whui520

'公式保存<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
'型材部分。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。
If e.Range.Intersect(Range("F_5280")) IsNot Nothing Then
Dim cell As IRange
            Dim lastRow As Long
            Dim destCol As Long
            Dim srcCol As Long
            Dim i As Long
            Dim Cells As IRange = ActiveWorkbook.ActiveWorksheet.Cells

            lastRow = Range("F_5245").RowCount + 14
      For i = 15 To lastRow
'确定源和目标列
            srcCol = 11 'L列
            destCol = 6 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
'<<<<<<<<<<<<<<<<<<<<<<<<<<
For i = 15 To lastRow
'确定源和目标列
            srcCol = 15 'L列
            destCol = 7 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
For i = 15 To lastRow
'确定源和目标列
            srcCol = 16 'L列
            destCol = 8 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
   End If
   '玻璃公式保存。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。
If e.Range.Intersect(Range("F_5280")) IsNot Nothing Then
Dim cell As IRange
            Dim lastRow As Long
            Dim destCol As Long
            Dim srcCol As Long
            Dim i As Long
Dim h As Long
            Dim Cells As IRange = ActiveWorkbook.ActiveWorksheet.Cells
            '确定源和目标列
            lastRow = Range("F_5245").RowCount + 28
   h = Range("F_5245").RowCount + 17
      For i = h To lastRow
srcCol = 15 'L列
            destCol = 4 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
   '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
For i = h To lastRow
srcCol = 16 'L列
            destCol = 5 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
For i = h To lastRow
srcCol = 17 'L列
            destCol = 6 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
For i = h To lastRow
srcCol = 18 'L列
            destCol = 7 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
   End If
'       开启扇///////////////////////////////////////////////////////
If e.Range.Intersect(Range("F_5280")) IsNot Nothing Then
Dim cell As IRange
            Dim lastRow As Long
            Dim destCol As Long
            Dim srcCol As Long
            Dim i As Long
Dim h As Long
            Dim Cells As IRange = ActiveWorkbook.ActiveWorksheet.Cells
            '确定源和目标列
            lastRow = Range("F_5245").RowCount + 21
   h = Range("F_5245").RowCount + 17
      For i = h To lastRow
srcCol = 19 'L列
            destCol = 10 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
   '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
For i = h To lastRow
srcCol = 20 'L列
            destCol = 11 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
For i = h To lastRow
srcCol = 21 'L列
            destCol = 13 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
For i = h To lastRow
srcCol = 22 'L列
            destCol = 12 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
   End If

whui520

whui520 发表于 2023-6-29 03:01
'公式保存

'<<<<<<<<<<<<<<<<五金配置>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
If e.Range.Intersect(Range("F_5280")) IsNot Nothing Then
Dim cell As IRange
            Dim lastRow As Long
            Dim destCol As Long
            Dim srcCol As Long
            Dim i As Long
Dim h As Long
            Dim Cells As IRange = ActiveWorkbook.ActiveWorksheet.Cells
            '确定源和目标列
            lastRow = Range("F_5245").RowCount + 35
   h = Range("F_5245").RowCount + 31
      For i = h To lastRow
srcCol = 16 'L列
            destCol = 4 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
   '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
For i = h To lastRow
srcCol = 15 'L列
            destCol = 7 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
   End If
'《《《《《《《《《《《辅材配置》》》》》》》》》》》》》》》》
If e.Range.Intersect(Range("F_5280")) IsNot Nothing Then
Dim cell As IRange
            Dim lastRow As Long
            Dim destCol As Long
            Dim srcCol As Long
            Dim i As Long
Dim h As Long
            Dim Cells As IRange = ActiveWorkbook.ActiveWorksheet.Cells
            '确定源和目标列
            lastRow = Range("F_5245").RowCount + 35
   h = Range("F_5245").RowCount + 24
      For i = h To lastRow
srcCol = 19 'L列
            destCol = 12 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
   '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
For i = h To lastRow
srcCol = 20 'L列
            destCol = 13 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
   End If

whui520

whui520 发表于 2023-6-29 03:07
'>>>>>>>>>>>>>>>>
If e.Range.Intersect(Range("F_5280")) IsNot Nothing Then
Dim cell As IRang ...

If e.Shape.Name = "执行计算" Then
            '型材部分。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。
'填写符合条件后执行的代码
            Dim lastRow As Long
            Dim destCol As Long
            Dim srcCol As Long
            Dim i As Long
            Dim Cells As IRange = ActiveWorkbook.ActiveWorksheet.Cells
            lastRow = Range("F_5245").RowCount + 14
            '循环从第16行开始向下转换数据
            For i = 15 To lastRow
   srcCol = 11 'L列
                  destCol = 6 'G
                  '将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
'《《《《《《《《《《
For i = 15 To lastRow
   srcCol = 15 'L列
                  destCol = 7 'G
                  '将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
'《《《《《《《《《《
For i = 15 To lastRow
   srcCol = 16 'L列
                  destCol = 8 'G
                  '将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
         End If
'玻璃部分........................................................
If e.Shape.Name = "执行计算" Then
'填写符合条件后执行的代码
            Dim lastRow As Long
            Dim destCol As Long
            Dim srcCol As Long
            Dim i As Long
   Dim h As Long
            Dim Cells As IRange = ActiveWorkbook.ActiveWorksheet.Cells


            lastRow = Range("F_5245").RowCount + 28
   h = Range("F_5245").RowCount + 16+1

            For i = h To lastRow
                  srcCol = 15 'L列
   destCol = 4 'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
   For i = h To lastRow
                  srcCol = 16'L列
   destCol = 5'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
   For i = h To lastRow
                  srcCol = 17'L列
   destCol = 6'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
For i = h To lastRow
                  srcCol = 18'L列
   destCol = 7'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
         End If
'开启扇部分.......................................................................
If e.Shape.Name = "执行计算" Then
'填写符合条件后执行的代码
            Dim lastRow As Long
            Dim destCol As Long
            Dim srcCol As Long
            Dim i As Long
   Dim h As Long
            Dim Cells As IRange = ActiveWorkbook.ActiveWorksheet.Cells
            '确定源和目标列

            lastRow = Range("F_5245").RowCount + 21
   h = Range("F_5245").RowCount + 16+1
            '循环从第16行开始向下转换数据
            For i = h To lastRow
                  srcCol = 19 'L列
   destCol = 10 'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
   For i = h To lastRow
                  srcCol = 20'L列
   destCol = 11'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
   For i = h To lastRow
                  srcCol = 21'L列
   destCol = 13'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
For i = h To lastRow
                  srcCol = 23'L列
   destCol = 12'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
   End If
'五金配置部分............................................................
If e.Shape.Name = "执行计算" Then
'填写符合条件后执行的代码
            Dim lastRow As Long
            Dim destCol As Long
            Dim srcCol As Long
            Dim i As Long
   Dim h As Long
            Dim Cells As IRange = ActiveWorkbook.ActiveWorksheet.Cells
            '确定源和目标列

            lastRow = Range("F_5245").RowCount + 35
   h = Range("F_5245").RowCount + 31
            '循环从第16行开始向下转换数据
            For i = h To lastRow
                  srcCol = 16 'L列
   destCol = 4 'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
   For i = h To lastRow
                  srcCol = 15'L列
   destCol = 7'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
   End If
'辅材配置表。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。
If e.Shape.Name = "执行计算" Then
'填写符合条件后执行的代码
            Dim lastRow As Long
            Dim destCol As Long
            Dim srcCol As Long
            Dim i As Long
   Dim h As Long
            Dim Cells As IRange = ActiveWorkbook.ActiveWorksheet.Cells
            '确定源和目标列

            lastRow = Range("F_5245").RowCount + 35
   h = Range("F_5245").RowCount + 24
            '循环从第16行开始向下转换数据
            For i = h To lastRow
                  srcCol = 19 'L列
   destCol = 12 'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
   For i = h To lastRow
                  srcCol = 20'L列
   destCol = 13'G'将当前行的L列数据转换为公式并将其写入G列
                  Cells(i, destCol).Formula = "=" & Cells(i, srcCol).Value
If Cells(i, srcCol).Value = "" Then'如果L列当前行的数据是空，则退出循环
   Cells(i, destCol).Value = ""
                     Exit For
                  End If
   Next i
   End If

whui520

whui520 发表于 2023-6-29 03:12
If e.Shape.Name = "执行计算" Then
'型材部分。。。。。。。。。。。。。。。。。。。。 ...

'>>>>>>>>>>>>>>>>>>>>>>>>>>>>保存公式<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
If e.Shape.Name = "保存公式" Then
Dim cell As IRange
            Dim lastRow As Long
            Dim destCol As Long
            Dim srcCol As Long
            Dim i As Long
            Dim Cells As IRange = ActiveWorkbook.ActiveWorksheet.Cells

            lastRow = Range("F_5245").RowCount + 14
      For i = 15 To lastRow
'确定源和目标列
            srcCol = 11 'L列
            destCol = 6 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
'<<<<<<<<<<<<<<<<<<<<<<<<<<
For i = 15 To lastRow
'确定源和目标列
            srcCol = 15 'L列
            destCol = 7 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
For i = 15 To lastRow
'确定源和目标列
            srcCol = 16 'L列
            destCol = 8 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
   End If
   '玻璃公式保存。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。
If e.Shape.Name = "保存公式" Then
Dim cell As IRange
            Dim lastRow As Long
            Dim destCol As Long
            Dim srcCol As Long
            Dim i As Long
Dim h As Long
            Dim Cells As IRange = ActiveWorkbook.ActiveWorksheet.Cells
            '确定源和目标列
            lastRow = Range("F_5245").RowCount + 28
   h = Range("F_5245").RowCount + 17
      For i = h To lastRow
srcCol = 15 'L列
            destCol = 4 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
   '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
For i = h To lastRow
srcCol = 16 'L列
            destCol = 5 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
For i = h To lastRow
srcCol = 17 'L列
            destCol = 6 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
For i = h To lastRow
srcCol = 18 'L列
            destCol = 7 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
   End If

whui520

whui520 发表于 2023-6-29 03:17
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>保存公式

开启扇///////////////////////////////////////////////////////
If e.Shape.Name = "保存公式" Then
Dim cell As IRange
            Dim lastRow As Long
            Dim destCol As Long
            Dim srcCol As Long
            Dim i As Long
Dim h As Long
            Dim Cells As IRange = ActiveWorkbook.ActiveWorksheet.Cells
            '确定源和目标列
            lastRow = Range("F_5245").RowCount + 21
   h = Range("F_5245").RowCount + 17
      For i = h To lastRow
srcCol = 19 'L列
            destCol = 10 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
   '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
For i = h To lastRow
srcCol = 20 'L列
            destCol = 11 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
For i = h To lastRow
srcCol = 21 'L列
            destCol = 13 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
For i = h To lastRow
srcCol = 22 'L列
            destCol = 12 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
   End If
'<<<<<<<<<<<<<<<<五金配置>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
If e.Shape.Name = "保存公式" Then
Dim cell As IRange
            Dim lastRow As Long
            Dim destCol As Long
            Dim srcCol As Long
            Dim i As Long
Dim h As Long
            Dim Cells As IRange = ActiveWorkbook.ActiveWorksheet.Cells
            '确定源和目标列
            lastRow = Range("F_5245").RowCount + 35
   h = Range("F_5245").RowCount + 31
      For i = h To lastRow
srcCol = 16 'L列
            destCol = 4 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
   '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
For i = h To lastRow
srcCol = 15 'L列
            destCol = 7 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
   End If
'《《《《《《《《《《《辅材配置》》》》》》》》》》》》》》》》
If e.Shape.Name = "保存公式" Then
Dim cell As IRange
            Dim lastRow As Long
            Dim destCol As Long
            Dim srcCol As Long
            Dim i As Long
Dim h As Long
            Dim Cells As IRange = ActiveWorkbook.ActiveWorksheet.Cells
            '确定源和目标列
            lastRow = Range("F_5245").RowCount + 35
   h = Range("F_5245").RowCount + 24
      For i = h To lastRow
srcCol = 19 'L列
            destCol = 12 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
   '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
For i = h To lastRow
srcCol = 20 'L列
            destCol = 13 'G
         If cells(i , destCol)  .HasFormula Then
         Dim formulaText As String
      formulaText =cells(i , destCol) .Formula

      ' 去除等号
Do While InStr(formulaText, "=") > 0
formulaText = Replace(formulaText, "=", "")
Loop

      ' 去除空格
  formulaText = Trim(formulaText)

      ' 复制结果到相邻单元格
  cells(i , destCol) .Offset(0, srcCol - destCol).Value = formulaText
   End If
Next i
   End If
   End Sub'按钮/标签点击事件

hessen

神一样的存在

whui520

whui520

whui520

whui520

whui520

whui520

hessen

精彩评论6

whui520

whui520

whui520

whui520

whui520

hessen

产品与服务

网站地图