VBA根据Shee1中某列关键词把结果复制到Sheet2中进行交叉互算快表软件

楼主

本帖最后由 hong90342 于 2026-6-11 12:05 编辑

VBA根据Sheet1中某列关键词把结果复制到Sheet2中进行交叉运算
使用场景：excel中嵌套自动计算，sheet1从sheet2中取数，然后把结果返回sheet2再进行二次计算。

Imports SpreadsheetGear
Imports C1.Silverlight
Imports C1.Silverlight.C1MessageBoxButton
Imports C1.Silverlight.C1MessageBoxIcon
Imports Newtonsoft.Json
Imports Newtonsoft.Json.Linq
Imports Microsoft.VisualBasic
Imports System.IO
Imports System.Text
Imports System.Net
Imports System.Windows.forms
Imports System.Collections.Generic
Namespace ExcelViewVBDotnet
Public Class StandardInterface
'预留位置1
'预留位置2
Dim EV As SpreadsheetGear.Windows.Controls.WorkbookView
Dim AW As SpreadsheetGear.IWorkbook
Dim Range As SpreadsheetGear.IRange
'==================== 可配置区域，按需修改即可，无需动核心逻辑 ====================
Private Const SourceSheetName As String = "Sheet1"
Private Const TargetSheetName As String = "Sheet2"
Private Const KeywordColumn As Integer = 12 ' 取数来源列，按您的要求固定为12
Private Const MatchKeyColumn As Integer = 1 ' A列：项目匹配列
Private Const CopyStartColumn As Integer = 33 ' AH列：复制起始列
Private Const CopyEndColumn As Integer = 45 ' AT列：复制结束列
Private Const MatchKeyword As String = "自动取数计算" ' 匹配关键词
Private Const SourceHeaderRow As Integer = 7 ' Sheet1表头行号
Private Const TargetHeaderRow As Integer = 2 ' Sheet2表头行号
' 关闭所有调试弹窗，运行流畅无卡顿
Private Const EnableDebugPopup As Boolean = False
Private Const ShowColumnDebug As Boolean = False
'====================================================================================
Public Sub Workbook_Open(OldRoot As Object, NewRoot As Object, Excel As SpreadsheetGear.Windows.Controls.WorkbookView)
EV = Excel
Excel.GetLock()
AW = Excel.ActiveWorkbook
Range = AW.ActiveWorksheet.Range
Excel.ReleaseLock()
End Sub
Public Sub RangeSelection(sender As Object, e As SpreadsheetGear.Windows.Controls.RangeSelectionChangedEventArgs)
End Sub
Public Sub RangeChanged(sender As Object, e As SpreadsheetGear.Windows.Controls.RangeChangedEventArgs)
End Sub
Public Sub ButtunClick(sender As Object, e As SpreadsheetGear.Windows.Controls.ShapeActionEventArgs)
AW.WorkbookSet.GetLock()
Dim buttonName As String = e.Shape.Name
AW.WorkbookSet.ReleaseLock()
If buttonName = "Button 22" Then
Try
CopyDataByCondition()
Catch ex As Exception
C1MessageBox.Show(ex.Message, "操作失败", C1MessageBoxButton.OK, C1MessageBoxIcon.Error)
End Try
End If
End Sub
Public Sub FollowHyperlink(sender As Object)
End Sub
''' <summary>
''' 核心业务逻辑：按条件匹配更新AH-AS列范围，修复API调用错误
''' </summary>
Private Sub CopyDataByCondition()
Try
AW.WorkbookSet.GetLock()
AW.WorkbookSet.Calculation = Calculation.Manual
' 工作簿与工作表校验
If AW Is Nothing Then
Throw New Exception("错误：工作簿未加载")
End If
Dim wsSource As IWorksheet = AW.Worksheets(SourceSheetName)
Dim wsTarget As IWorksheet = AW.Worksheets(TargetSheetName)
If wsSource Is Nothing Then Throw New Exception("错误：Sheet1 不存在")
If wsTarget Is Nothing Then Throw New Exception("错误：Sheet2 不存在")
' 列范围合法性校验
If CopyStartColumn > CopyEndColumn Then
Throw New Exception("配置错误：复制起始列(" & CopyStartColumn & ") > 复制结束列(" & CopyEndColumn & ")")
End If
' 【89行核心修复：SpreadsheetGear中IWorksheet无ColumnCount属性，需通过Cells属性获取】
Dim maxSheetColumn As Integer = wsSource.Cells.ColumnCount
If CopyEndColumn > maxSheetColumn Then
Throw New Exception("配置错误：复制结束列(" & CopyEndColumn & ") > 表格最大列数(" & maxSheetColumn & ")")
End If
' 1. 预加载目标表匹配字典
Dim targetMatchDict As Dictionary(Of String, Integer)
targetMatchDict = New Dictionary(Of String, Integer)()
Dim targetDataStartRow As Integer = TargetHeaderRow + 1
Dim targetUsedRng As IRange = wsTarget.UsedRange
Dim targetUsedRngStartRow As Integer = targetUsedRng.Row
Dim targetUsedRngRowCount As Integer = targetUsedRng.RowCount
Dim targetLastRow As Integer = targetUsedRngStartRow + targetUsedRngRowCount - 1
' 遍历目标表，填充匹配字典
For targetRow As Integer = targetDataStartRow To targetLastRow
Dim targetKeyValue As Object = wsTarget.Cells(targetRow, MatchKeyColumn).Value
If targetKeyValue IsNot Nothing AndAlso Not String.IsNullOrEmpty(targetKeyValue.ToString()) Then
Dim keyStr As String = targetKeyValue.ToString().Trim()
If Not targetMatchDict.ContainsKey(keyStr) Then
targetMatchDict.Add(keyStr, targetRow)
End If
End If
Next
If targetMatchDict.Count = 0 Then
Throw New Exception("提示：Sheet2中无有效项目数据，无法匹配")
End If
' 2. 遍历源表，按条件匹配更新
Dim sourceDataStartRow As Integer = SourceHeaderRow + 1
Dim sourceUsedRng As IRange = wsSource.UsedRange
Dim sourceUsedRngStartRow As Integer = sourceUsedRng.Row
Dim sourceUsedRngRowCount As Integer = sourceUsedRng.RowCount
Dim sourceLastRow As Integer = sourceUsedRngStartRow + sourceUsedRngRowCount - 1
If sourceLastRow < sourceDataStartRow Then
Throw New Exception("提示：Sheet1中无有效数据行，起始行：" & sourceDataStartRow & "，最后行：" & sourceLastRow)
End If
' 统计信息
Dim updateSuccessRowCount As Integer = 0
Dim matchKeywordCount As Integer = 0
Dim noMatchCount As Integer = 0
Dim targetColumnEmptyCount As Integer = 0
' 遍历源表数据行
For sourceRow As Integer = sourceDataStartRow To sourceLastRow
' 读取取数来源列内容
Dim keywordCellValue As Object = wsSource.Cells(sourceRow, KeywordColumn).Value
If keywordCellValue Is Nothing OrElse String.IsNullOrEmpty(keywordCellValue.ToString().Trim()) Then
targetColumnEmptyCount += 1
Continue For
End If
' 关键词清洗与匹配
Dim rawContent As String = keywordCellValue.ToString()
Dim cleanContent As String = rawContent.Trim().Replace(vbCrLf, "").Replace(vbTab, "").Replace("　", "")
Dim cleanKeyword As String = MatchKeyword.Trim().Replace("　", "")
Dim isKeywordMatch As Boolean = InStr(1, cleanContent, cleanKeyword, CompareMethod.Text) > 0
If Not isKeywordMatch Then
Continue For
End If
' 统计匹配到关键词的行数
matchKeywordCount += 1
' 获取A列项目匹配值
Dim sourceKeyValue As Object = wsSource.Cells(sourceRow, MatchKeyColumn).Value
If sourceKeyValue Is Nothing Then
noMatchCount += 1
Continue For
End If
Dim sourceKeyStr As String = sourceKeyValue.ToString().Trim()
If String.IsNullOrEmpty(sourceKeyStr) Then
noMatchCount += 1
Continue For
End If
' 字典匹配目标行号
If Not targetMatchDict.ContainsKey(sourceKeyStr) Then
noMatchCount += 1
Continue For
End If
Dim targetRow As Integer = targetMatchDict(sourceKeyStr)
' 批量复制AH-AS列范围的数值与格式
Try
' 遍历AH到AS的每一列，完成复制
For currentCol As Integer = CopyStartColumn To CopyEndColumn
Dim sourceCellValue As Object = wsSource.Cells(sourceRow, currentCol).Value
Dim sourceCellNumberFormat As String = wsSource.Cells(sourceRow, currentCol).NumberFormat
wsTarget.Cells(targetRow, currentCol).Value = sourceCellValue
wsTarget.Cells(targetRow, currentCol).NumberFormat = sourceCellNumberFormat
Next
' 统计成功更新的行数
updateSuccessRowCount += 1
Catch ex As Exception
Throw New Exception("更新失败：源行" & sourceRow & " → 目标行" & targetRow & "，列范围" & CopyStartColumn & "-" & CopyEndColumn & "，错误：" & ex.Message)
End Try
Next

复制代码

hong90342

产品与服务

网站地图