本文于2023年8月18日首发于本人同名其他平台，更多文章案例请搜索关注！
内容提要
工程项目报价表数据提取整理
格式调整
大家好，我是冷水泡茶，有位粉丝朋友在文章【Excel VBA 按同一个项目合并单元格文字】下面留言：
说实话，看文字还真没看明白，我就让他把文件发我瞅瞅，原来他是要把工程报价表中的C列的部分文字合并，填到D列（插入列），他的源表是这样的：
中间还有一个分页：
他的需求表是这个样子的：
我经过一番研究，分析他原来数据的规律，正如他所说，跟我前面分享的案例有几分相似，我们一起来看一看吧：
基本思路
1、把不需要的标题删除，我们可以通过删除B列为空的行。
2、目标表的表头字段与原表的表头字段不完全一样，索性删除重新添加，可以通过查找关键字的方法定位到表头行，将其删除。
3、最难的地方，是把B列为空的单元格，对应的C列单元格的字符连起来，还要跳过两个工程名称行。
4、在C列后面插入一列，把拼接好的字段填到D列对应的项目名称行。
5、把B列为空的行，除了两个工程名称行，统统删除。
程序代码
1、ManipulateData，操作数据：
Sub ManipulateData() Dim sourceWs As Worksheet Dim targetWs As Worksheet Dim wsName As String Dim lastRow As Integer Dim tbTitle(), strMerge As String Dim rng As Range Dim arrWidth() Application.ScreenUpdating = False Set sourceWs = ThisWorkbook.ActiveSheet arrWidth = Array(5, 15, 15, 50, 8, 10, 12, 16) wsName = "清洗表" If sourceWs.Name = wsName Then Exit Sub tbTitle = Array("序号", "项目编码", "项目名称", "项目特征描述", "计量单位", "工程量", "综合单价", "合价") Call CopyWorksheet(sourceWs, wsName) '删除小计行以下的行 Set targetWs = ThisWorkbook.Sheets(wsName) With targetWs lastRow = targetWs.UsedRange.Rows.Count For i = lastRow To 1 Step -1 If Cells(i, 3) = "" Then Rows(i).Delete End If Next For i = lastRow To 1 Step -1 If InStr(Cells(i, 3), "小") > 0 And InStr(Cells(i, 3), "计") > 0 Then Rows(i & ":" & lastRow).Delete End If Next For i = lastRow To 1 Step -1 If InStr(Cells(i, 3), "名称") > 0 And InStr(Cells(i, 3), "特征") > 0 Then Rows(i).Delete End If Next .Columns(4).Insert Shift:=xlToRight .Columns("I:I").Delete .Rows(1).Insert Shift:=xlDown .Range("A1").Resize(1, UBound(tbTitle) + 1) = tbTitle lastRow = targetWs.UsedRange.Rows.Count For i = 4 To lastRow If .Cells(i, 2) <> .Cells(i - 1, 2) Then m = i If .Cells(i, 2) <> "" Then k = i End If End If If .Cells(i, 2) <> .Cells(i + 1, 2) Then If .Cells(i, 2) = "" Then If InStr(Cells(i, 3), "工程") > 0 Then n = i - 1 Else n = i End If For j = m To n strMerge = strMerge & .Cells(j, 3) & Chr(10) Next strMerge = Left(strMerge, Len(strMerge) - 1) .Cells(k, 4) = strMerge strMerge = "" End If ElseIf Cells(i + 1, 3) = "" Then n = i For j = m To n strMerge = strMerge & .Cells(j, 3) & Chr(10) Next strMerge = Left(strMerge, Len(strMerge) - 1) .Cells(k, 4) = Trim(strMerge) strMerge = "" End If If .Cells(i, 3) = "" Then Exit For Next lastRow = .UsedRange.Rows.Count For i = lastRow To 3 Step -1 If .Cells(i, 2) = "" Then If InStr(Cells(i, 3), "工程") = 0 Then .Rows(i).Delete End If End If Next lastRow = .UsedRange.Rows.Count .Rows(2).ClearFormats With .Range(Cells(1, 1), Cells(lastRow, 3)) .ClearFormats .VerticalAlignment = xlCenter End With With .Range(Cells(1, 6), Cells(lastRow, 8)) .ClearFormats .VerticalAlignment = xlCenter .NumberFormatLocal = "_ * #,##0.00_ ;_ * -#,##0.00_ ;_ * ""-""??_ ;_ @_ " End With With .Cells(1, 1).Resize(lastRow, UBound(tbTitle) + 1) .Borders.LineStyle = xlDot ' 边框线的样式为连续线 .Borders.Weight = xlThin ' 边框线的粗细为细线 .Borders.ColorIndex = xlAutomatic ' 边框线的颜色为自动 End With .Cells.Font.Size = 11 .Rows(1).HorizontalAlignment = xlCenter .Columns(1).HorizontalAlignment = xlCenter For i = LBound(arrWidth) To UBound(arrWidth) .Columns(i + 1).ColumnWidth = arrWidth(i) Next End With Call DeleteButtons(targetWs) targetWs.Rows.AutoFit targetWs.Range("A1").Select Application.ScreenUpdating = TrueEnd Sub
代码解析：
（1）定义一些变量。
（2）把源工作表sourceWs设为当前活动工作表。
（3）arrWidth数组，存放目标表的列宽，最后完成的表的列宽就按照这个数组的值来顺序确定，可根据需要调整。
（4）设置目标表名称wsName，如果当前活动工作表的名称也等于wsName，说明源表不对，直接退出过程。
（5）tbTitle ，存放新表头字段名称。
（6）Call CopyWorksheet 复制源工作表为目标工作表。
（7）把targetWs设为复制的新表，下面的操作均针对targetWs进行。
（8）通过循环，删除“所有空白行。这里要从下往上删除。
（9）通过循环，删除“小计”以下的所有行。这里他的小计中间有空格，我们用Instr函数判断是否同时包含“小”和“计”，不管有多少空格就不受影响了。
（10）通过循环，删除表头行。这里跟删除小计行差不多，判断是否包含“名称”和“特征“两个字段。
（11）.Columns(4).Insert Shift:=xlToRight，在第4列也就是D列插入一列。删除多余的I列，有格式。
（12） .Rows(1).Insert Shift:=xlDown，第一行插入空白行。接着把tbTitle的字段写入第一行。
（13）从第4行开始循环，寻找定位需要组合字符的行，m表示开头，n表示结尾，k表示项目编码或项目名称行，后面字符组合完成后，填入D列，k行。
（14）拼接字符填充完毕后，把不需要的行删除，就是上面的m~n行，但我们在删除的时候，采用删除B列空行的方法，跳过工程名称那一行。
（15）接着，设置单元格的格式，包括对齐，划线，数字格式等。
（16）Call DeleteButtons，删除目标工作表中的所有按钮。
2、其他过程：CopyWorksheet、DeleteButtons：
Sub CopyWorksheet(sourceWorksheet As Worksheet, wsName As String) Dim targetWorksheet As Worksheet '检查是否存在同名的目标工作表，如果存在则删除 On Error Resume Next Set targetWorksheet = ThisWorkbook.Worksheets(wsName) On Error GoTo 0 If Not targetWorksheet Is Nothing Then Application.DisplayAlerts = False targetWorksheet.Delete Application.DisplayAlerts = True End If '复制源工作表到同一个工作簿 sourceWorksheet.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) '获取新复制的工作表的引用 Set targetWorksheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) '重命名新复制的工作表 targetWorksheet.Name = wsNameEnd SubSub DeleteButtons(ws As Worksheet) Dim obj As OLEObject '循环遍历工作表上的所有 OLE 对象（包括命令按钮） For Each obj In ws.OLEObjects obj.Delete ' 删除命令按钮 NextEnd Sub
代码解析：
（1）CopyWorksheet，复制工作表，过程参数：源工作表sourceWorksheet，新工作表名wsName ，把“源工作表”复制成以“新工作表名”命名的工作表。
（2）DeleteButtons，删除目标工作表中的所有按钮，我们直接复制工作表，连按钮也会一起复制过来，需要把它们删除。
总结
1、本文涉及了很多工作表的操作，比如，复制工作表，删除行、列，插入行，设置单元格的格式等。
2、像今天的案例，如果用数组来处理，就没有直接操作工作表来得方便了，因为数组插入、删除行列是非常麻烦的，没有工作表来得快。
3、如果数据量特别大，在数组里操作也是可行的。这里就不再展开。
---End---
喜欢就点个赞、点在看、留个言呗！分享一下更给力！感谢！