请问各位老师怎么通过宏实现excel中判断，提取匹配这一系列复杂的操作

tonyjump

各位老师，公司实操中有个表格需要一直重复处理，在这里请教一下大家能否用宏实现重复操作：
整个表格分3个sheet，sheet1是会不断添加的源数据，sheet2 上海和sheet3 外地是两个需要从源数据获取并做一定改变的。
希望实现的功能：
1. 判断：sheet2 和sheet 3能够首先根据sheet1中的城市名称列做判断，sheet2只获取城市名称是上海列的数据，sheet3只获取城市名称列是非上海的数据。
2. 数据提取和匹配：sheet1的表头最全，sheet2 和sheet3 在判断后能从源数据中获取其他数据列的数据（其中派遣/委托，希望能识别后相应填充1,2见批注，公积金比例格式按照批注中的填充）
3.格式调整：sheet2和sheet3获取的数据希望能全部设置文本格式
以上，
各位老师，非常不好意思做伸手党，但是这个有点急用，非常谢谢能给我回复的朋友。

jiahb2001

sheet2列表头 有 18个与sheet1列表头 对不上的 期待高手出现，学习下

tonyjump

对的，就是想从一张总表里面，分情况自动提取和转换格式

wc110wc110

马克一下

wc110wc110

你sheet2和sheet3的有些表头不在sheet1里啊 ，怎么提取

0126

嗯，你表里有些首行标题跟总表对应首行标题有些出入，要改成一样的 ，像这个标题（报价单产品收费启示日），在三个表里面各有各名称，
Sub xxx()
Dim x As Long, y As Long, st As String, brr() As String, d, arr, crr() As String, l1 As Long, l2 As Long
Set d = CreateObject("scripting.dictionary")
arr = Sheets("表1").UsedRange: arr1 = Sheets("上海").UsedRange: arr2 = Sheets("外地").UsedRange
ReDim brr(1 To 10000, 1 To UBound(arr1, 2)): ReDim crr(1 To 10000, 1 To UBound(arr2, 2))
l1 = UBound(arr1) + 1: l2 = UBound(arr2) + 1
For x = 1 To UBound(arr, 2)                                   '创建表标题字典
  If arr(1, x) <> "" Then d(arr(1, x)) = x
Next
For x = 1 To UBound(arr1, 2)
  If arr1(1, x) <> "" Then d(arr1(1, x) & 1) = x
Next
For x = 1 To UBound(arr2, 2)
  If arr2(1, x) <> "" Then d(arr2(1, x) & 2) = x
Next

For x = 2 To UBound(arr)                           '查找总表表头标题在其他表位置，有放入数据，无跳过
  If arr(x, d("城市名称")) = "上海" Then
   k1 = k1 + 1
   For y = 1 To UBound(arr, 2)
    If d.exists(arr(1, y) & 1) Then brr(k1, d(arr(1, y) & 1)) = arr(x, y)
   Next
  Else
   k2 = k2 + 1
   For y = 1 To UBound(arr, 2)
    If d.exists(arr(1, y) & 2) Then crr(k2, d(arr(1, y) & 2)) = arr(x, y)
   Next
  End If
Next
  
  With CreateObject("VBScript.RegExp")                      '用正则表达式提取匹配标注里的数据
       .Global = True
      Sheets("上海").Range("a" & l1 + 1).Resize(k1, UBound(arr1, 2)) = brr
      For Each rg In Sheets("上海").Cells.SpecialCells(xlCellTypeComments)
       For x = l1 To k1 + l1
        If rg.Offset(x, 0) = "" Then GoTo 10
        .Pattern = "\d+(?=[^1-9]?" & rg.Offset(x, 0) & ")"
        If .test(rg.Comment.Text) = False Then GoTo 10
        rg.Offset(x, 0) = .Execute(rg.Comment.Text)(0)
10     Next
      Next
      Sheets("外地").Range("a" & l2 + 1).Resize(k2, UBound(arr2, 2)) = crr
      For Each rg In Sheets("外地").Cells.SpecialCells(xlCellTypeComments)
       For x = l2 To k2 + l2
        .Pattern = "\d+(?=[^1-9]?" & rg.Offset(x, 0) & ")"
        If .test(rg.Comment.Text) = False Or rg.Offset(x, 0) = "" Then GoTo 11
        rg.Offset(x, 0) = .Execute(rg.Comment.Text)(0)
11     Next
      Next
  End With
End Sub

grf1973

表一的表头要规范，尽量不用(),\等符号；
表二提取的表头内容最好和表一完全一致。
用ado做了上海的，非上海的稍微修改即可。
表二表头和表一对应不起来的用null做了处理。

jiahb2001

grf1973 发表于 2017-9-21 16:39
表一的表头要规范，尽量不用(),\等符号；
表二提取的表头内容最好和表一完全一致。
用ado做了上海的，非 ...

又学到了，用Null 代替空字段，但是 要写字段太长了  能简化不

0126

grf1973 发表于 2017-9-21 16:39
表一的表头要规范，尽量不用(),\等符号；
表二提取的表头内容最好和表一完全一致。
用ado做了上海的，非 ...

大神，能指教一下吗，我f8运行到第二句代码时出错了，

tonyjump

grf1973 发表于 2017-9-21 16:39
表一的表头要规范，尽量不用(),\等符号；
表二提取的表头内容最好和表一完全一致。
用ado做了上海的，非 ...

多谢老师，厉害了，我去专研专研