Home>

Therefore, this question will be closed. >

About the contents of the bulletin.

The number of horizontal data is the same, but the number of vertical data is not constant.
Is it possible to create a VBA that creates a new sheet in an Excel file that contains multiple sheets and then transcribes the contents of all sheets vertically into the sheet?


Item title | Input company name | April | May | June |
A item | A operating company | 200 | 300 | 0 |
B item | A business company | 100 | 0 | 20 |


Item title | Input company name | April | May | June |
A item | B operating company | 100 | 500 | 40 |
B item | B operating company | 0 | 0 | 50 |
C item | B operating company | 0 | 20 | 0 |

:
: (About 10 sheets, the number of sheets is not constant)

I want to create a new sheet as shown below and put it together.
Item title | Input company name | April | May | June |
A item | A operating company | 200 | 300 | 0 |
B item | A business company | 100 | 0 | 20 |
A item | B operating company | 100 | 500 | 40 |
B item | B operating company | 0 | 0 | 50 |
C item | B operating company | 0 | 20 | 0 |
:
:

  • Answer # 1

    Is it like this?
    Using the item information on the leftmost sheet, the other sheets connect only the data from the second line.
    When creating again, delete the summary sheet and execute.

    Option Explicit
    Sub VJoin ()
        Dim newWS As Worksheet
        Set newWS = ThisWorkbook.Worksheets.Add (before: = ThisWorkbook.Worksheets (1))
        newWS.Name = "Summary"
        Dim ws As Worksheet
        Dim endRow As Long
        Dim endClm As Long
        Dim srcEndRow As Long
        Dim srcEndClm As Long
        endRow = 0
        For Each ws In ThisWorkbook.Worksheets
            If ws.Name<>"Summary" Then
                If endRow = 0 Then
                    endClm = ws.Cells (1, Columns.Count) .End (xlToLeft) .Column
                    endRow = ws.Cells (1, 1) .End (xlDown) .Row
                    ws.Range (ws.Cells (1, 1), ws.Cells (endRow, endClm)). Copy newWS.Cells (1, 1)
                Else
                    srcEndClm = ws.Cells (1, Columns.Count) .End (xlToLeft) .Column
                    srcEndRow = ws.Cells (1, 1) .End (xlDown) .Row
                    If srcEndClm = endClm And srcEndClm