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
"Lib" wrote:
> 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
>
>
|
Similar Threads
