遍历所有表单，如果cell = string，则将三个单元格复制到特殊表单
我正在使用excel 2007.我有一个发票系统，在其中input采购订单编号，并生成一个新的发票，并将该采购单编号作为工作表名称，并将其复制到同一工作表上的单元格，然后从那里它被手动填写并保存。 每个发票在单元格C6中具有十四种电源types之一（例如，打印耗材或从下拉列表中select的清洁耗材）。 这一切都很好。
我想跟踪每种供应types花费多less，所以我需要通过每个发票，检查供应types，并复制三个不连续的单元格（date（A6：B6），宝＃（F6：G6）和金额（G39））添加到该供应types的“支票簿样式”表中的一行。
我猜这个伪代码看起来像这样：
- 对于每张纸，检查单元格c6中的供应types
- 如果供应types正在打印，
- 将新的三个单元格值写入名为“打印”的工作表，否则继续下一步
- 如果供应types正在清洁，
- 将新的三个单元格值写入名为“清洗”的工作表
- 等等，“如果”自杀死亡。
下面是我所做的，只是通过所有表单复制单元格，而不按供应types进行sorting – 然后试图让它只使用打印发票没有成功。
Sub CopyRangeFromPrintingWorksheets() Dim sh As Worksheet Dim DestSh As Worksheet Dim Last As Long Dim CopyRng As Range With Application .ScreenUpdating = False .EnableEvents = False End With 'Delete the sheet "Printing" if it exist Application.DisplayAlerts = False On Error Resume Next ActiveWorkbook.Worksheets("Printing").Delete On Error GoTo 0 Application.DisplayAlerts = True 'Add a worksheet with the name Set DestSh = ActiveWorkbook.Worksheets.Add DestSh.Name = "Printing" 'loop through all worksheets and copy the data to the DestSh For Each sh In ActiveWorkbook.Worksheets 'If sh.Name <> DestSh.Name Then If InStr(1, Worksheets(wks.Name).Range("C6:E6").Value, "Printing/Stationary 532-110", vbTextCompare) = 1 Then ' If LCase(Left(sh.Name, 4)) = "tly-" Then 'Find the last row with data on the DestSh Last = LastRow(DestSh) 'Fill in the range that you want to copy Set CopyRng = sh.Range("G3") 'Test if there enough rows in the DestSh to copy all the data If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then MsgBox "There are not enough rows in the Destsh" GoTo ExitTheSub End If 'This copies values/formats, want to copy the 'values or want to copy everything CopyRng.Copy With DestSh.Cells(Last + 1, "B") .PasteSpecial xlPasteValues .PasteSpecial xlPasteFormats Application.CutCopyMode = False End With 'Optional: This will copy the sheet name in the A column DestSh.Cells(Last + 1, "A").Resize(CopyRng.Rows.Count).Value = sh.Name 'Copy ordered by cell to column C DestSh.Cells(Last + 1, "D").Resize(CopyRng.Rows.Count).Value = sh.Range("G39") 'Copy date cell to proper column DestSh.Cells(Last + 1, "C").Resize(CopyRng.Rows.Count).Value = sh.Range("C6") DestSh.Cells(Last + 1, "E").Resize(CopyRng.Rows.Count).Value = sh.Range("E8") End If Next ExitTheSub: Application.GoTo DestSh.Cells(1) 'AutoFit the column width in the DestSh sheet DestSh.Columns.AutoFit With Application .ScreenUpdating = True .EnableEvents = True End With 我甚至研究过select案例，但仍然没有成功。 试图录制一个marco，并没有灵感地看着这个代码。 这似乎应该不是那么难…但我不知道最实际的方法去做。 一个正确的方向指针将是太棒了！
用VBA解决这个问题是可能的，但是这将会非常麻烦和脆弱。
这种方法的一个问题是，你有数据存储在多个地方，可能会不同步。 另外，您需要三种不同的数据视图：
- 单logging视图（即单个采购订单）
- 多logging视图（即“支票簿样式”），可能按供应types分组或过滤
- 摘要视图（给定date范围和/或供应types的总计）
在Access或更严重的数据库系统中，这是相当微不足道的，但是一点search就会让我相信，在Excel中，你可以得到两个以上但不是全部三个。 尽pipe如此，下面的链接可能会有所帮助：
你可以使用三维引用来求和数据，但我不认为你可以从三维引用创build数据透视表（对于支票簿式的视图）：
您还可以将多个工作表整合到数据透视表中，但是看起来源数据必须已经处于支票簿式视图中，因此无法获得数据的单一发票视图：
底线：如果你有一些时间来致力于这一点，我build议将解决scheme移到Access。
我得出了与phoog相同的结论，但方向不同。 下面我通过你的代码build议改变，但我觉得很难相信你可以做这个工作。
要点1
你有多个工作簿打开？ 在运行你的macros之前，你们之间切换吗？ 假设你有三个工作簿（A，B和C）是开放的。 假设此macros和发票在工作簿A中。如果在启动macros时使用工作簿C，则C将为ActiveWorkBook。 可以跨多个工作簿运行macros，但是它增加了一些复杂性，我相信你可以不用。 如果在启动macros时仅打开一个工作簿，则不需要ActiveWorkbook. 。
第2点
我不喜欢使用On Error来避免错误。 这可能不重要，但删除一些东西，然后重新创build它感觉不对我。 我会这样做：
Dim DestSh as Worksheet Dim Found As Boolean Dim InxWS As Integer Found = False For InxWS = 1 To Worksheets.Count If Worksheets(InxWS).Name = "Printing" Then Found = True ' Use whichever of the following two statements is most appropriate ' This completely deletes the contents of the worksheet Worksheets(InxWS).Cells.EntireRow.Delete ' This deletes the contents of the worksheet but keeps the column widths Worksheets(InxWS).Cells.EntireRow.ClearContents Exit For End If Next If Not Found Then Set DestSh = Worksheets.Add DestSh.Name = "Printing" End If
第3点
我没有看到以下的错误：
For Each sh In Worksheets If sh.Name <> DestSh.Name Then End If Next
For Each来说，通过工作表是一个非常好的方式。
您需要一些方法来检查您是否正在检查工作表“正在打印”。 但是，如果目标工作表始终是“打印”，我可能会写sh.Name <> "Printing" 。
另一方面，如果我想炫耀，我会写：
Const DestShName as String = "Printing" : : DestSh.Name = DestShName : : If sh.Name <> DestShName Then
有了这个代码，我可以通过改变Const（常量）语句来改变目标工作表的名字。
第4点
考虑：
Worksheets(wks.Name).Range("C6:E6").Value
什么是wks ？ for的variables是sh ？
我猜你没有Option Explicit作为你的模块的第一行。 Option Explicit说你想禁止使用未声明的variables。
Worksheets(sh.Name)与sh相同。
我假设“C6：E6”已合并。 如果您想要合并区域的值，请使用左上angular的单元格。 所以Range("C6").Value 。
您的select案例将在表格上：
With sh Select Case .Range("C6").Value Case "Printing" ' Do something Case "Cleaning" ' Do something Case "Stationary" ' Do something Case "Books" : : Case Else ' Do something about an unknown supply type End Select End With
第5点
如果我理解正确，你有14种供应types，每种都有自己的目的地表单。 您将需要在循环中Select Case一个像这样的Select Case来准备目标工作表。 供应types是否与工作表名称相同？ 如果不是的话，这将会变得非常混乱，特别是如果你添加另一种供应types。
这可能值得考虑一下数组。
Dim InxShST as Integer Dim SheetNameList() as String Dim SupplyTypeList() as String SheetNameList = Array("Print", "Clean", "Stat", ... ) SupplyTypeList = Array("Printing supplies", "Cleaning supplies", ... )
使用同一顺序的表名和供应types，您可以在采购订单中find供应types，并将其转换为表单名称。 如果您添加新的供应types，只需在每个数组的末尾添加一个新值即可。
回到第2点。我build议你忘记添加VBA的工作表。 手工创build14张。
代码变成：
For InxWS = 1 To Worksheets.Count For InxShST = LBound(SheetNameList) To UBound(SheetNameList) If Worksheets(InxWS).Name = SheetNameList(InxShST) Then Worksheets(InxWS).Cells.EntireRow.ClearContents Exit For End If Next Next
我承认这个比较复杂，但是可以根据需要准备好多张。 您有两个循环：一个用于工作表，一个用于工作表名称。 当你得到一场比赛，你有一张纸需要清理。 LBound代表下界。 UBound代表上限。 第二个For-Loop调整到数组的大小。
你可以使用：
For Each SheetNameCrnt In SheetNameList
这看起来可能更简单。 但通过使用索引，您可以将SheetNameList(InxShST)与SupplyTypeList(InxShST)
其他点
您确定每个采购订单都需要一张工作表吗？ 你有一天有多less采购订单。 10？ 100？ 500？ 这可能是一个非常难以pipe理的工作手册。
从macros中的其他语句中，我假设你有一个固定的头，然后每个产品有一个数据行sorting。 您不定义这些行的性质，但我想你想要将它们复制到适当的工作表。
我也许可以猜测这些数据行的结构，但是我必须质疑你的devise。 如果我向您订购打印机墨盒和一些肥皂粉，是否需要两份采购订单？ 我不认为你会赢得我的生意。