求助大神怎么提取数据

bi7jvw

1：料号总表里的信息不定期人工增加。                                                                                           2：如何能才能简单的点一个按键如“提取”就会从料号总表中按类型提取到新的工作表中且不能重复或覆盖。                           
      @：如IC类就提到IC Sheet中，贴片IC就提到贴片IC Sheet中。
料号总表1.rar (11.51 KB, 下载次数: 37)

2015-10-15 17:51 上传

点击文件名下载附件

zax010

Sub zz()
    Dim d, d1, ar, br, bt
    Set d = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    bt = Array("材料类别", "物料代码", "物料名称", "规格型号", "单位", "是否贴片", "是否通用", "材料存储要求", "代码申请人", "品牌信息", "备注", "状态", "是否禁选")
    Application.ScreenUpdating = False
    ar = Sheet1.Range("A1").CurrentRegion
    For Each sh In Sheets
        d1(sh.Name) = ""
    Next
    For i = 2 To UBound(ar)
        d(ar(i, 3)) = d(ar(i, 3)) & "," & i
    Next
    For Each k In d.keys
        ReDim br(1 To UBound(ar), 1 To 13)
        m = 0: s = Split(Mid(d(k), 2), ",")
        For i = 0 To UBound(s)
            m = m + 1: x = Val(s(i))
            For j = 1 To 5
                br(m, j) = ar(x, j)
            Next
            For j = 6 To 12
                br(m, j) = ar(x, j + 6)
            Next
            br(m, 13) = ar(x, 26)
        Next
        If Not d1.exists(k) Then
            Sheets.Add after:=Sheets(Sheets.Count)
            With ActiveSheet
                .[a1].Resize(1, UBound(bt) + 1) = bt: .[a2].Resize(m, 13) = br
                .Columns("A:M").EntireColumn.AutoFit
                .UsedRange.Borders.LineStyle = xlContinuous: .Name = k
            End With
        Else
            With Sheets(k)
                lr = .[a65536].End(3).Row + 1: .Cells(lr, 1).Resize(m, 13) = br
                .UsedRange.Borders.LineStyle = xlContinuous
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub

zax010

>>>>>>>>>>>>>>>>>>

料号总表1.rar (21.53 KB, 下载次数: 40)

2015-10-15 22:46 上传

点击文件名下载附件

bi7jvw

zax010 发表于 2015-10-15 22:47
>>>>>>>>>>>>>>>>>>

太叼了这个功能，谢谢大神

bi7jvw

zax010 发表于 2015-10-15 22:47
>>>>>>>>>>>>>>>>>>

换到别的表怎么弹出这个？


Sub zz()
    Dim d, d1, ar, br, bt
    Set d = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    bt = Array("材料类别", "物料代码", "物料名称", "规格型号", "单位", "是否贴片", "是否通用", "材料存储要求", "代码申请人", "品牌信息", "备注", "状态", "是否禁选")
    Application.ScreenUpdating = False
    ar = Sheet1.Range("A1").CurrentRegion
    For Each sh In Sheets
        d1(sh.Name) = ""
    Next
    For i = 2 To UBound(ar)
        d(ar(i, 3)) = d(ar(i, 3)) & "," & i
    Next
    For Each k In d.keys
        ReDim br(1 To UBound(ar), 1 To 13)
        m = 0: s = Split(Mid(d(k), 2), ",")
        For i = 0 To UBound(s)
            m = m + 1: x = Val(s(i))
            For j = 1 To 5
                br(m, j) = ar(x, j)
            Next
            For j = 6 To 12
                br(m, j) = ar(x, j + 6)
            Next
            br(m, 13) = ar(x, 26)
        Next
        If Not d1.exists(k) Then
            Sheets.Add after:=Sheets(Sheets.Count)
            With ActiveSheet
                .[a1].Resize(1, UBound(bt) + 1) = bt: .[a2].Resize(m, 13) = br
                .Columns("A:M").EntireColumn.AutoFit
                .UsedRange.Borders.LineStyle = xlContinuous: .Name = k
            End With
        Else
            With Sheets(k)
                lr = .[a65536].End(3).Row + 1: .Cells(lr, 1).Resize(m, 13) = br
                .UsedRange.Borders.LineStyle = xlContinuous
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub

zax010

bi7jvw 发表于 2015-10-16 09:31
换到别的表怎么弹出这个？

错误提示已说的很清楚。

用第三列数据做工作表名称，这些数据中包含了不允许用的字符： : \ / ? * 等。

bi7jvw

zax010 发表于 2015-10-16 09:44
错误提示已说的很清楚。

用第三列数据做工作表名称，这些数据中包含了不允许用的字符： : \ / ? * 等 ...

那么可有办法解决这个

zax010

bi7jvw 发表于 2015-10-16 15:50
那么可有办法解决这个

用近似的或不引起混淆的字符把那些字符替换掉：

Sub zz()
    Dim d, d1, ar, br, bt
    Set d = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    bt = Array("材料类别", "物料代码", "物料名称", "规格型号", "单位", "是否贴片", "是否通用", "材料存储要求", "代码申请人", "品牌信息", "备注", "状态", "是否禁选")
    zf1 = Array(":", "\", "/", "?", "*", "[", "]")
    zf2 = Array("∶", "|", "_", "？", "※", "［", "］")
    Application.ScreenUpdating = False
    ar = Sheet1.Range("A1").CurrentRegion
    For Each sh In Sheets
        d1(sh.Name) = ""
    Next
    For i = 2 To UBound(ar)
        d(ar(i, 3)) = d(ar(i, 3)) & "," & i
    Next
    For Each k In d.keys
        For y = 0 To UBound(zf1)
            If InStr(k, zf1(y)) Then
                kk = Replace(k, zf1(y), zf2(y))
            End If
        Next
        If kk = "" Then kk = k
        ReDim br(1 To UBound(ar), 1 To 13)
        m = 0: s = Split(Mid(d(k), 2), ",")
        For i = 0 To UBound(s)
            m = m + 1: x = Val(s(i))
            For j = 1 To 5
                br(m, j) = ar(x, j)
            Next
            For j = 6 To 12
                br(m, j) = ar(x, j + 6)
            Next
            br(m, 13) = ar(x, 26)
        Next
        If Not d1.exists(kk) Then
            Sheets.Add after:=Sheets(Sheets.Count)
            With ActiveSheet
                .[a1].Resize(1, UBound(bt) + 1) = bt: .[a2].Resize(m, 13) = br
                .Columns("A:M").EntireColumn.AutoFit
                .UsedRange.Borders.LineStyle = xlContinuous: .Name = kk: kk = ""
            End With
        Else
            With Sheets(kk)
                lr = .[a65536].End(3).Row + 1: .Cells(lr, 1).Resize(m, 13) = br
                .UsedRange.Borders.LineStyle = xlContinuous
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub

zax010

bi7jvw 发表于 2015-10-16 15:50
那么可有办法解决这个

>>>>>>>>>>>>>>>>>>>>>>

料号总表1.rar (24.36 KB, 下载次数: 49)

2015-10-16 19:52 上传

点击文件名下载附件

bi7jvw

zax010 发表于 2015-10-16 19:53
>>>>>>>>>>>>>>>>>>>>>>

非常感谢大侠