VBA：在制项目物料状态表引用“特殊事项”（涉及多工作表引用、数据接龙式粘贴、利用公式引用、引用区域数据粘贴为数值）

领导想在生产任务跟踪表的在制物料状态表中引用周计划跟踪表的备注事项
表内容如下

由于备注事项分别在各个工作中，而且存在相同的机床编号，所以引用后还要进行数据的清理。
基本思路是先建一个中间表，遍历所需要的数据源表，将需要的数据引用到中间表中，进行清理后，再通过vlookup引用到目标表中（使用字典太麻烦，用公式引用快一点）

在工程中增如下模块

先进行数据引用 ，在getdata_zjh中代码如下

Public Sub GetData()
    Dim sourceWorkbook As Workbook
    Dim sourceWorksheet As Worksheet
    Dim targetWorkbook As Workbook
    Dim targetWorksheet As Worksheet
    Dim sourceRange As Range
    Dim targetRange As Range
    Dim sourceArray() As Variant
    Dim sheetname As String, path As String
    Dim i As Long, j As Long, k As Long
    Dim scount As Long, tcount As Long, lastrow As Long, newcount As Long
    Dim rng As Range
    Dim arr, brr, crr, tarr

   sheetname = "周计划源表引用"

    ' 遍历工作簿中的所有工作表，检查是否存在同名工作表
    For Each ws In ThisWorkbook.Sheets
        If ws.Name = sheetname Then
         i = 1
        End If
    Next ws
    '如果没有则新增
    If i = 0 Then
      Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
      ws.Name = sheetname
    End If
    Worksheets(sheetname).Select
    Set targetWorkbook = ThisWorkbook
    Set targetWorksheet = ActiveSheet

''引用他表的数据
   path = ThisWorkbook.path ''  "\\192.168.100.5\生产中心\生产保障部"
    ''同一个文件夹下的文件就=ThisWorkbook.Path

   f = Dir(path & "\3# 周计划跟踪表.xlsx")
    If f = "" Then
        MsgBox "源文件不存，请查看"
        Exit Sub
    Else
        Set sourceWorkbook = Workbooks.Open(path & "\" & f, ReadOnly:=True)
    End If

'''遍历源表取数据

   sourceArray = Array("营销", "研究院", "总一", "总二", "军工", "液压", "电气施工", "电气程序", "质量部")
'   sourceArray = Array("液压")
   lastrow = 1
   For i = LBound(sourceArray) To UBound(sourceArray)

       '获取源表数据
       For Each sourceWorksheet In sourceWorkbook.Worksheets
         If sourceWorksheet.Name = sourceArray(i) Then
            scount = sourceWorksheet.Range("A" & Rows.Count).End(xlUp).Row '获取源表总行数
            ReDim arr(1 To scount, 1 To 2)
            Set arr = sourceWorksheet.Range("B3:B" & scount) '获取机床编号
            Set arr = Union(arr, sourceWorksheet.Range("G3:G" & scount)) '获取内容
         End If
       Next
       
       '将数据复制到目标表
       targetWorksheet.Activate
       tcount = targetWorksheet.Range("A" & Rows.Count).End(xlUp).Row '获取目标表总行数
       Set tarr = ActiveSheet.Range("A1:B" & scount)
       arr.Copy tarr.Range("A" & tcount + 1)
       '判断数据是否为空，为空删除，不为空加“部门维度”标识
       newcount = targetWorksheet.Range("A" & Rows.Count).End(xlUp).Row '重新获取目标表总行数
       For j = newcount To tcount + 1 Step -1
          If Range("B" & j).Value = "" Or IsEmpty(Range("B" & j).Value) Then
            Rows(j).Delete Shift:=xlUp
          Else
            Range("B" & j).Value = sourceArray(i) & "维度:" & Chr(10) & Range("B" & j).Value
          End If
       Next j

   Next
   ActiveSheet.Cells(1, 1) = "机床编号"
   ActiveSheet.Cells(1, 2) = "特殊事项"
   ActiveSheet.UsedRange.Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlYes  '排序
'关闭源工作簿，并不保存更改
 sourceWorkbook.Close SaveChanges:=False

End Sub

再进行数据清理，mergedata模块代码如下：

Sub mergedata()
Dim tcount As Long
Dim i As Long

 '''合并相同机床编号的内容
 Worksheets("周计划源表引用").Activate
 
 tcount = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row '获取目标表总行数
 For i = tcount To 2 Step -1
  If Range("A" & i) = Range("A" & i - 1) Then
     Range("B" & i - 1) = Range("B" & i - 1) & Chr(10) & Range("B" & i)
     Rows(i).Delete Shift:=xlUp
  End If
 Next

'''设置格式
 tcount = 0
 tcount = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row '重新获取目标表总行数
   ActiveSheet.UsedRange.Select
   With Selection.Font
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
    End With
  
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

    With Selection.Font
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
    End With
 
 
End Sub

最后进行数据引用，reference模块代码如下

'使用vlookup引用数据
Sub reference()
Dim i As Long
Dim rowsum As Long, colcount As Long
Dim colnum As Variant

   Worksheets("在制项目物料状态 (2)").Activate
   rowsum = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row '总行数
   colcount = ActiveSheet.Cells(3, Columns.Count).End(xlToLeft).Column '总列数
   '查询目标单元格所在列
   For i = 1 To colcount
     If Cells(3, i) = "周计划特殊事项" Then
     colnum = i
     Exit For
     End If
   Next
   
   '设置引用公式
   For i = 4 To rowsum
     Cells(i, colnum).Select
     ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP([@机床编号],周计划源表引用!C[-23]:C[-22],2,FALSE),"""")"  '使用R1C1模式
   Next i
   
   '引用数据粘贴为数值
   rowsum = 0
   rowsum = ActiveSheet.Cells(Rows.Count, colnum).End(xlUp).Row '需覆盖数据的总行数
   Range(Cells(4, colnum), Cells(rowsum, colnum)).Select'选中区域
   Application.CutCopyMode = False ' 清除剪贴板状态
   With Selection
    .Copy
    .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False '只粘贴数值
    .WrapText = True '文本自动换行
    .Orientation = 0 '单元格中文本的方向
    .AddIndent = False '文本添加缩进
    .ShrinkToFit = False '自动调整字体大小以适应单元格的宽度
   End With
     
     
     
     
'删除售服源数据
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("周计划源表引用").Delete
Application.DisplayAlerts = True
     

End Sub

在数据表中增一个按钮，代码如下

Private Sub CommandButton1_Click()

Application.ScreenUpdating = False  '关闭屏幕更新，加快程序运行
Application.DisplayAlerts = False   '不显示警告信息

 getdata_zjh.GetData
 mergedata.mergedata
 reference.reference
 
Application.ScreenUpdating = True
Application.DisplayAlerts = True
 
End Sub

效果如下：