数式を含む行をメインシートにコピー

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