将带有公式的行复制到主工作表

Question

我有一本工作簿，我们在其中进行报价成本计算。有一个名为“成本核算表”的主表和可以具有不同名称的各个表。所有工作表都具有相同的格式，第一行作为标题。我只想要一个宏，它将在“成本核算表”中的 A 列中搜索一个值，并与其他工作表的 A 列中的值进行比较，如果找到，则复制整行 A：W 从带有公式和格式的单个工作表到“成本核算”表”对匹配值。我创建了一个宏，它复制所有数据并创建一个新工作表。但这并没有给我想要的输出。我搜索了几个论坛，但找不到相同的。如果你能帮助我，那将是很大的帮助这是我用于创建新工作表的代码

Sub CopyFromWorksheets()
Dim wrk As Workbook 
Dim sht As Worksheet 
Dim trg As Worksheet 
Dim rng As Range 
Dim colCount As Integer 
Set wrk = ActiveWorkbook 

For Each sht In wrk.Worksheets
    If sht.Name = "Master" Then
        MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
        "Please remove or rename this worksheet since 'Master' would be" & _
        "the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
        Exit Sub
    End If
Next sht


Application.ScreenUpdating = False


Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
 'Rename the new worksheet
trg.Name = "Master"
 'Get column headers from the first worksheet
 'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
 'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
    .Value = sht.Cells(1, 1).Resize(1, colCount).Value
     'Set font as bold
    .Font.Bold = True
End With

 'We can start loop
For Each sht In wrk.Worksheets
     'If worksheet in loop is the last one, stop execution (it is Master worksheet)
    If sht.Index = wrk.Worksheets.Count Then
        Exit For
    End If
     'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
    Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
     'Put data into the Master worksheet
    trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Formula
Next sht
 'Fit the columns in Master worksheet
trg.Columns.AutoFit
 Sheets("Master").Select
colCount = Range("A" & Rows.Count).End(xlUp).Row

Range("L2:L" & colCount).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 'Screen updating should be activated
Application.ScreenUpdating = True

Sheets("Costing Sheet").Select
End Sub

Answer 1

您的代码的目标似乎是在“主”工作表中创建所有其他工作表内容的副本。如果那是您所寻求的，那么此代码符合您的要求。我不明白删除具有空列 L 的任何行的代码，只是将其注释掉。

Option Explicit
Sub CopyFromWorksheets()

  Dim sht As Worksheet
  Dim trg As Worksheet
  Dim rng As Range
  ' ## Long matches the natural size of an integer on a 32-bit computer.
  ' ## A 16-bit Integer variable is, I am told, slightly slower in execution.
  Dim colCount As Long
  Dim rowCount As Long    ' ## Added by me.  See later.
  Dim rowTrgNext As Long  ' ## Added by me.  See later.

  ' ## The active workbook is the default workbook.  You can have several
  ' ## workbooks open and move data between them.  If you were doing this
  ' ## then identifying the required workbook would be necessary.  In your
  ' ## situation wrk has no value.  You could argue it does no harm but I
  ' ## dislike extra, unnecessary characters because I believe they make the
  ' ## code harder to understand.  I have remove all references to wrk.

  For Each sht In Worksheets
    If sht.Name = "Master" Then
      MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
             "Please remove or rename this worksheet since 'Master' would be " & _
             "the name of the result worksheet of this process.", _
             vbOKOnly + vbExclamation, "Error"
             Exit Sub
    End If
  Next sht

  'Application.ScreenUpdating = False
  Set trg = Worksheets.Add(After:=Worksheets(Worksheets.Count))
  'Rename the new worksheet
  trg.Name = "Master"
  'Get column headers from the first worksheet
  'Column count first
  Set sht = Worksheets(1)
  ' ## 255 is the maximum number of columns for Excel 2003.
  ' ## Columns.Count gives the maximum number of columns for any version.
  colCount = sht.Cells(1, Columns.Count).End(xlToLeft).Column
  'Now retrieve headers, no copy&paste needed
  ' ## Excel VBA provides alternative ways of achieving the same result.
  ' ## No doubt this is an accident of history but it is considered poor
  ' ## language design.  I avoid Resize and Offset (which you use later)
  ' ## because I find the resultant statements difficult to get right in
  ' ## the first place and difficult to understand when I need to update
  ' ## the code six or twelve months later.  I find .Range("Xn:Ym") or
  ' ## .Range(.Cells(n, "X"),.Cells(m, "Y")) easier to get right and
  ' ## easier to understand.  I am not asking you to agree with me; I am
  ' ## asking to consider what you would find easiest to get right and
  ' ## easiest to understand when you look at this code in six months.
  ' ## I have changed your code to show you the approach I prefer.
  Set rng = sht.Range(sht.Cells(1, 1), sht.Cells(1, colCount))
  With trg
    With .Range(.Cells(1, 1), .Cells(1, colCount))
      .Value = rng.Value
      'Set font as bold
      .Font.Bold = True
    End With
  End With
  rowTrgNext = 2    ' ## See later

  'We can start loop
  For Each sht In Worksheets
    'If worksheet in loop is the last one, stop execution
    ' (it is Master worksheet)
    ' ## I would favour
    ' ##    If sht.Name = "Master" Then
    ' ## because  think it is clearer.
    If sht.Index = Worksheets.Count Then
      Exit For
    End If
    ' ## 1) 65536 is the maximum number of rows for Excel 2003.
    ' ##    Rows.Count gives the maximum number of rows for any version.
    ' ## 2) As explained earlier, I do not like Resize or Offset.
    ' ## 3) I avoid doing more than one thing per statement if it means
    ' ##    I have to think hard about what is being achieved.
    ' ## 4) Rather than use End(xlUp) to determine the last unused row in
    ' ##    worksheet Master, I maintain the value in rowTgtNext.
    'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
    With sht
      ' ## Are you sure column A is full on every sheet
      ' ## This returns the last row used regardless of column
      rowCount = .Cells.SpecialCells(xlCellTypeLastCell).Row
      Set rng = sht.Range(.Cells(2, 1), .Cells(rowCount, colCount))
    End With
    'Put data into the Master worksheet
    ' ## This copies everything: formulae, formats, etc.
    rng.Copy Destination:=trg.Range("A" & rowTrgNext)
    rowTrgNext = rowTrgNext + rowCount - 1
  Next sht
  'Fit the columns in Master worksheet
  trg.Columns.AutoFit

  ' ## I do not know what this is trying to achieve.
  ' ## It will delete any row that does not have a value in column L
  ' ## providing at least one cell in column L does contain a value.
  'Sheets("Master").Select
  'colCount = Range("A" & Rows.Count).End(xlUp).Row
  'Range("L2:L" & colCount).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  'Screen updating should be activated

  Application.ScreenUpdating = True
  Sheets("Costing Sheet").Select

End Sub