Copy worksheets to new worksheet and add a worksheet name column to new sheet.

[Lib]

I have a workbook that contains 6 sheets. I managed to create the
code to copy those sheets onto one worksheet. Now I want to add a
column to the new worksheet that lists the worksheet name for each row
that was copied from a particular worksheet. (That way, it will be
easier to identify which worksheet that row came from in the new
worksheet.) For example, say I copied four rows with five columns
from Worksheet "A" and 7 rows with five columns from Worksheet "B"
onto the new Worksheet "1". I want to create a new column in the
Worksheet "1" that will identify each row as either coming from
Worksheet A or coming from Worksheet B.

I'll take any help I can get! If you do post, please add comments to
explain what was exactly done. Thanks!

Here's my code so far:

Sub CombinedStatus()

Dim J As Integer
Dim InsertRow As Integer
Dim InsertSheet As Integer
Dim ExtractRow As Integer
Dim MaxColumns As Integer
Dim StartSheet As Integer
Dim StartRow As Integer
Dim HeaderRow As Integer
Dim ExtractSheet As Integer
Dim ExtractCol, InsertCol, MaxInsertCol As Integer
Dim MatchCol As Variant

On Error Resume Next
Sheets(1).Select
Sheets(1).Cells.Clear
Sheets(1).Interior.ColorIndex = xlNone
Sheets(1).Name = "CombinedStatus"

'copy headings
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
Sheets(1).Column("I").Name = "DT_LOAD"

' work through sheets
For J = 2 To 7 ' from sheet 2 to last sheet
' make the sheet active
Sheets(J).Activate
Range("A1").Select
' select all cells in this sheets
Selection.CurrentRegion.Select
' select all lines except title
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
' copy cells selected in the new sheet on last line
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)
(2)

Next
Sheets(1).Activate
Columns("I:I").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="<09/06/2006",
Operator:=xlAnd
Rows("2:797").Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter Field:=1

Selection.Sort Key1:=Range("I2"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
_
DataOption1:=xlSortTextAsNumbers
Range("A1:I1").Select
Selection.AutoFilter
Columns("A:I").Select
Selection.Columns.AutoFit
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("A:I").Select
Selection.Columns.HorizontalAlignment = xlCenter

End Sub

 

[Guest]

I'm not sure about your deleting rows, but try the following (I used
variables instead of hard coding your columns, rows, and worksheet names. It
makes adjusting in the future easier):

Sub CombinedStatus()

Dim headerRow As Long
Dim dataRow As Long
Dim combineWorksheet As Integer
Dim dataWorksheetStart As Integer
Dim worksheetColumn As String
Dim pasteColumn As String

Dim worksheetIndex As Integer
Dim lastRow As Long
Dim pasteRow As Long

Dim J As Integer
Dim InsertRow As Integer
Dim InsertSheet As Integer
Dim ExtractRow As Integer
Dim MaxColumns As Integer
Dim StartSheet As Integer

Dim ExtractSheet As Integer
Dim ExtractCol, InsertCol, MaxInsertCol As Integer
Dim MatchCol As Variant

'Setup variables (could make constants above procedure declaration)
headerRow = 1
dataRow = 2
combineWorksheet = 1
dataWorksheetStart = 2
worksheetColumn = "A"
pasteColumn = "B"
filtercolumn = "J"

'Intialize first worksheet (delete any previous data)
Worksheets(combineWorksheet).Range("A1:IV65536").Delete shift:=xlUp
Worksheets(combineWorksheet).Name = "CombinedStatus"

'Copy headings from start data worksheet
Worksheets(dataWorksheetStart).Rows(headerRow).Copy
Worksheets(combineWorksheet).Rows(headerRow).Paste

'Change name of column filterColumn
Worksheets(combineWorksheet).Column(filtercolumn).Name = "DT_LOAD"

'Loop through data worksheets
For worksheetIndex = dataWorksheetStart To Worksheets.Count

'Get row count of region to copy
copyrowcount = Worksheets(worksheetIndex).CurrentRegion.Rows.Count - 1

'Copy cells in source worksheet
Worksheets(worksheetIndex).CurrentRegion.Offset(1, 0). _
Resize(Selection.Rows.Count - 1).Copy

'Paste in combined worksheet starting in paste column at last row
lastRow = Worksheets(combineWorksheet).Range("A65536").End(xlUp).Row
Worksheets(combineWorksheet).Range(pasteColumn & lastRow).Paste

'Enter worksheet name in worksheetColumn
For pasteRow = lastRow To (lastRow + copyrowcount - 1)
Worksheets(combineWorksheet).Range(worksheetColumn & pasteRow) = _
Worksheets(worksheetIndex).Name
Next
Next

'Turn on filter
With Worksheets(combineWorksheet).Columns(filtercolumn)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="<09/06/2006", Operator:=xlAnd
End With

'Unsure what you are doing here??
Worksheets(combineWorksheet).Rows("2:797").Select
Selection.Delete shift:=xlUp
Selection.AutoFilter Field:=1

'Sort data
Selection.Sort Key1:=Range("I2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortTextAsNumbers
Worksheets(combineWorksheet).Range(worksheetColumn & headerRow & ":" & _
filtercolumn & headerRow).AutoFilter
With Worksheets(combineWorksheet).Columns(worksheetcol & ":" & filtercolumn)
.AutoFit
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub