Excel VBA：从共享列值创build新表格

作为工作职责，我被告知要在Excel 2003中打开一个电子表格（很快就会获得一台较新的计算机…），并将一张工作表分成许多基于一个ID的工作表：Vendor Id＃。

工作表具有一行高的标题。 第一个Header列是“VendorID”。 现在，这里有每列的其他标题的DOZENS，它们包含方程 。 我希望工作表是供应商ID的名称。

我想要的是得到像这样的许多表：

名为“00708”的表单，“vendorId”的A列表头，其中包含：

vendid | B | C | D | 00708 | true | 1.07 | 4.52 | 

只是一个例子。 有许多不同的信息的列。 许多。

我的问题是，在工作中，我试过这个代码：

 Option Explicit Sub DistributeRows() Dim wsAll As Worksheet Dim wsCrit As Worksheet Dim wsNew As Worksheet Dim LastRow As Long Dim LastRowCrit As Long Dim I As Long Set wsAll = Worksheets("Sheet1") ' change All to the name of the worksheet the existing data is on LastRow = wsAll.Range("A" & Rows.Count).End(xlUp).Row Set wsCrit = Worksheets.Add ' column A has the criteria eg project ref wsAll.Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row For I = 2 To LastRowCrit Set wsNew = Worksheets.Add wsNew.Name = wsCrit.Range("A2") wsAll.Rows("1:" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), _ CopyToRange:=wsNew.Range("A1"), Unique:=False wsCrit.Rows(2).Delete Next I Application.DisplayAlerts = False wsCrit.Delete Application.DisplayAlerts = True End Sub 

问题是，这个代码工作BEAUTIFULLY ….直到我滚动更多的权利，并意识到，许多列，虽然仍然适当地移动，包含空格，不仅数字曾经是，但也是数字因素虽然Excel公式（增加他们旁边的单元格的值，那种事情）

所以基本上….是不是有一个明确的代码呢？ 我search了几个小时的networking，但是任何代码我都会给我错误，我很抱歉没有记住，所以我可以告诉你。 我非常肯定上面的代码是有用的，但是它发出了重要的信息和方程式，并使它们成为空白。

我有8000行，知道excel可以做65000行。 我已经看到了一些试图抓住angular落区域的代码，但是我并不需要它。 我需要一个抓取每一列和每一行的代码…查看第一个“types”的信息（在这种情况下，供应商ID）的第一个值，然后创build尽可能多的新工作表（在同一文档中）它需要为每个不同的供应商ID创build一个。

任何帮助将非常感激。 我想尽量不用手工操作。