作者：绿色风
分类：
时间：2022-08-17
浏览：156
楼主
水星钓鱼 |
如图所示：
将分表中第一列加粗的字体内容与主表（STOCK）对比，假如匹配成功，则将加粗字体下的内容插入到主表对应的匹配项下。
代码如下：
- Sub xyf()
- Application.ScreenUpdating = False
- On Error Resume Next
- Dim arr1(1 To 1000)
- Dim arr2(1 To 1000)
- Dim j, k
- Dim wks As Worksheet
- For Each wks In ThisWorkbook.Worksheets
- If wks.Name <> "stock" Then
- If MsgBox(prompt:="现在开始匹配" & wks.Name & "的数据", Buttons:=vbOKCancel) = 1 Then
- With wks
- .Range("a:e").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlNo
- j = 0
- Erase arr1, arr2
- For i = 1 To .Cells(65536, 1).End(xlUp).Row
- If .Cells(i, 1).Font.Bold = True Then
- arr1(j + 1) = .Cells(i, 1).Row
- arr2(j + 1) = .Cells(i, 1)
- j = j + 1
- End If
- Next
- End With
- With Worksheets("stock")
- For i = 1 To j - 1
- k = Application.WorksheetFunction.Match(arr2(i), .Range("a:a"), 0)
- If Err.Number = 0 Then
- .Range("a" & k + 1).Resize(arr1(i + 1) - arr1(i) - 1).EntireRow.Insert (xlShiftDown)
- wks.Range("a" & arr1(i) + 1).Resize(arr1(i + 1) - arr1(i) - 1).Copy .Range("a" & k + 1)
- End If
- Err.Clear
- Next
- End With
-
- End If
- End If
- Next
- Set obj = Worksheets("stock").Range("a1:F" & Worksheets("stock").Cells(65536, 6).End(xlUp).Row)
- With obj
- .SpecialCells(xlCellTypeBlanks).EntireRow.Interior.Color = 65535
- .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
- .Copy
- .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
- Application.CutCopyMode = False
- .RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6), Header:=xlYes
- End With
- Application.ScreenUpdating = True
- End Sub
附件如下：
 VBA.rar
|
2楼
随缘11 |
好难啊
 |
3楼
老糊涂 |
下载学习 |
免责声明
有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素，
经与ExcelTip.Net站长Apolloh商议并征得其同意，
现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示，
供有需要的人士查询使用，也慰缅曾经的论坛时代。
所示各个帖子的原作者如对版权有异议，
可与本人沟通提出，或于本站点留言，我们会尽快处理。
在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一