Question

也许有人知道，如何在VBA中执行此类操作：我在一张纸和第二张桌子上有一个模板。表格如下：

Unit    Project Project Name   Task Number   Invoice    Sum of Amount
304     136950  Name1               02.3    invoice1    156.45
304     136955  Name2               01.6    invoice1    22.35

因此，当我填写模板时，我需要检查单元命名是否相同，如果是，则应在模板中创建其他行。

目前，我有一个宏，它只分别为一行完成模板，对我来说问题是如果我创建一个支票，仍然因为＆＃34; For Each ...＆＃ 34;我面临着创建新工作表而不是行的问题。

由于我在VBA中很新，是否有可能帮助我解决这个问题，例如，如果Unit在1+行上相同（按单位设置的顺序，那么就赢了＆＃39 ;是在几行之后重复单位的情况），而不是创建带有填充模板的新工作表，模板中的新行会被创建吗？

宏我现在有：

  Set myRange = Range(Sheets("Data").Cells(2, 1), Sheets("Data").Cells(2, 1).End(xlDown))

i = 1

For Each r In myRange.Cells


Sheets("template").Select
Sheets("template").Copy Before:=Sheets(1)
Sheets("template (2)").Select
Sheets("template (2)").Name = "Invoice " & i
Range("C1:D1").Select



ActiveSheet.Cells.Replace What:="{Unit}", Replacement:=r.Offset(0, 0), LookAt:=xlPart, _
                          SearchOrder:=xlByRows, MatchCase:=False, _
                          SearchFormat:=False, ReplaceFormat:=False


ActiveSheet.Cells.Replace What:="{pr number}", Replacement:=r.Offset(0, 1), LookAt:=xlPart, _
                          SearchOrder:=xlByRows, MatchCase:=False, _
                          SearchFormat:=False, ReplaceFormat:=False

ActiveSheet.Cells.Replace What:="{pr name}", Replacement:=r.Offset(0, 2), LookAt:=xlPart, _
                          SearchOrder:=xlByRows, MatchCase:=False, _
                          SearchFormat:=False, ReplaceFormat:=False


 ActiveSheet.Cells.Replace What:="{task nr}", Replacement:=r.Offset(0, 3), LookAt:=xlPart, _
                          SearchOrder:=xlByRows, MatchCase:=False, _
                          SearchFormat:=False, ReplaceFormat:=False

 ActiveSheet.Cells.Replace What:="{invoice number}", Replacement:=r.Offset(0, 4), LookAt:=xlPart, _
                          SearchOrder:=xlByRows, MatchCase:=False, _
                          SearchFormat:=False, ReplaceFormat:=False

ActiveSheet.Cells.Replace What:="{amount}", Replacement:=r.Offset(0, 5), LookAt:=xlPart, _
                          SearchOrder:=xlByRows, MatchCase:=False, _
                          SearchFormat:=False, ReplaceFormat:=False

i = i + 1

   Next r

应作为新行复制的范围存储在此处：

Range("A24:H29").Select 'templated data, which should be copied if new row needed and then here I'm fulfilling info from table
Selection.Copy
Range("A31").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = j + 1 'line number
Range("A33").Select

Answer 1

您可以使用For Loop。存储一个唯一的单位名称（例如 304 ），然后比较后续行（如果匹配）。找到不匹配后，您知道上面一行不匹配，存储唯一结尾的范围。然后将该范围复制到新创建的工作表。

Sub CreateNewTemplates()
    Dim wsTable As Worksheet
    Dim wsNewTemplate As Worksheet
    Dim rngStoredUnique As Range

    Set wsTable = Worksheets("Table") 'worksheet where all the data is
    With wsTable
        For x = 1 To 50 'adjust to your needs
            Set rngStoredUnique = .Cells(x, 1) 'adjust to your needs
            Sheets("template").Copy after:=Sheets("template") 'adjust to your needs
            Set wsNewTemplate = ActiveSheet
            wsNewTemplate.Name = "Invoice " & rngStoredUnique.Value 'adjust to your needs
            For y = 1 To 50 - x 'adjust to your needs
                If rngStoredUnique <> rngStoredUnique.Offset(y, 0) Then 'check if the unit below is different than stored
                    Set rngToCopy = .Range(rngStoredUnique, rngStoredUnique.Offset(y - 1, 0)).Resize(ColumnSize:=10) 'adjust to your needs
                    x = x + y - 1
                    rngToCopy.Copy Destination:=wsNewTemplate.Cells(1, 1) 'adjust to your needs
                    If rngStoredUnique.Offset(y, 0) = "" Then Exit Sub
                    Exit For
                End If
            Next y
        Next x
    End With
End Sub

带有附加行的Excel VBA fufilling模板

1 个答案: