Copy Sheet Name along with corresponding data.

[JTC1234]

For the code below, I need to copy the tab (sheet) name with the data being copied and transferred to the "Extract" sheet. I need the tab name to populate in column A for each corresponding row of data being copy from each sheet.



Private Sub CommandButton1_Click()

Dim xlastrow As Integer
Dim xrow As Integer
Dim t As String
Dim sht As Worksheet
Dim ws As Worksheet

counter = 0
Set sht = ActiveSheet

xrow = 2
xlastrow = b

Worksheets("Extract").AutoFilterMode = False

'PURPOSE: Select the next visible sheet in the spreadsheet

Set sht = ActiveSheet 'Store currently selected sheet

On Error Resume Next 'loop to next shet until visible one is found

Do While shet.Next.Visible <> xlSheetVisible
If Err <> 0 Then Exit Do
Set sht = sht.Next

Loop

sht.Next.Activate 'Activate/Select Next sheet

On Error GoTo 0

For Each ws In Sheets

If ws.Name <> "Original" Then

ws.Range("c10:w43").Copy 'Copy row on sheet1 meeting criteria
Worksheets("Extract").Activate 'Activate ExtractWorksheet
a = Worksheets("Extract").Cells(Rows.Count, 2).End(xlUp).Row 'Count rows on ExtractWorksheet
Worksheets("Extract").Cells(a + 1, 2).Select 'Moves cursor to next row in ExtractWorksheet
PasteSpecial (xlPasteValuesAndNumberFormats) 'Paste data in Sheet2

ws.Range("c47:w80").Copy 'Copy row on sheet1 meeting criteria
Worksheets("Extract").Activate 'Activate ExtractWorksheet
a = Worksheets("Extract").Cells(Rows.Count, 2).End(xlUp).Row 'Count rows on ExtractWorksheet
Worksheets("Extract").Cells(a + 1, 2).Select 'Moves cursor to next row in ExtractWorksheet
PasteSpecial (xlPasteValuesAndNumberFormats) 'Paste data in Sheet2

ws.Range("c84:w114").Copy 'Copy row on sheet1 meeting criteria
Worksheets("Extract").Activate 'Activate ExtractWorksheet
a = Worksheets("Extract").Cells(Rows.Count, 2).End(xlUp).Row 'Count rows on ExtractWorksheet
Worksheets("Extract").Cells(a + 1, 2).Select 'Moves cursor to next row in ExtractWorksheet
PasteSpecial (xlPasteValuesAndNumberFormats) 'Paste data in Sheet2

End If

Next ws

a = Worksheets("Extract").Cells(Rows.Count, 2).End(xlUp).Row 'Count rows on ExtractWorksheet
b = Worksheets("Extract").Cells(Rows.Count, 2).End(xlUp).Select

xlastrow = ActiveCell.Row

'PURPOSE: Delete any rows without WO#

Do Until xrow = xlastrow

If Cells(xrow, 3).Value = "" Then
Cells(xrow, 3).Select
Selection.EntireRow.Delete
xrow = xrow - 1
xlastrow = xlastrow - 1
End If

xrow = xrow + 1

Loop

xlastrow = ActiveCell.Row

Application.CutCopyMode = False
Worksheets("Extract").Activate
ThisWorkbook.Worksheets("Extract").Cells(1, 1).Select


End Sub

 

[Zot]

I'm trying to understand here

You want to:
1) Loop through all visible worksheets
2) Copy sheet name to column A, then copy 3 defined rows of data

After all done, delete rows without Work Order # (my guess) in column C

Is this correct?

 

[JTC1234]

I'm trying to understand here

You want to:
1) Loop through all visible worksheets
2) Copy sheet name to column A, then copy 3 defined rows of data

After all done, delete rows without Work Order # (my guess) in column C

Is this correct?

Zot,

Thanks for responding. See clarification below:

1. Loop through all visible worksheets
2. Copy 3 defined rows of data, then copy sheet name to column A to correspond with the three rows of data copy (essentially associating the sheet name with the 3 defined rows of data in column A).

Hope this helps.

 

[Zot]

I see that you have variables not used and also some codes doing nothing. Maybe you were writing while thinking what to do next. Yes ... I did that too from time to time because doing things on the spot ?

I rewrote the code, delete several lines which I think were doing nothing and modify few line. I hope this works. No data to test.... Let me know

Private Sub CommandButton1_Click()

Dim eRow As Long, a As Long
Dim ws As Worksheet, wsExtract As Worksheet
   
Set wsExtract = ActiveWorkbook.Sheets("Extract")
   
wsExtract.AutoFilterMode = False

'PURPOSE: Loop through all visible sheets and copy designated data into sheet Extract
For Each ws In Sheets
    If ws.Name <> "Original" And ws.Visible = True Then
        a = wsExtract.Cells(Rows.Count, 2).End(xlUp).Row + 1      'Get the next empty row
        wsExtract.Range("A" & a) = ws.Name
        ws.Range("c10:w43").Copy        'Copy row on sheet1 meeting criteria
        wsExtract.Range("B" & a).PasteSpecial (xlPasteValuesAndNumberFormats)       'Paste data in Sheet2
        a = a + 1
           
        ws.Range("c47:w80").Copy        'Copy row on sheet1 meeting criteria
        wsExtract.Range("B" & a).PasteSpecial (xlPasteValuesAndNumberFormats)       'Paste data in Sheet2
        a = a + 1
           
        ws.Range("c84:w114").Copy        'Copy row on sheet1 meeting criteria
        wsExtract.Range("B" & a).PasteSpecial (xlPasteValuesAndNumberFormats)       'Paste data in Sheet2
    End If
Next ws
   
'PURPOSE: Delete any rows without WO#
Dim rngData As Range, rngWOWO As Range

' Find end of row on Sheet Exctract refering to column B
eRow = Worksheets("Extract").Cells(Rows.Count, "B").End(xlUp).Row

' Set range of data with WO#
Set rngData = Worksheets("Extract").Range("C2", "C" & eRow)            ' Assuming range starts from row 2

For Each cell In rngData
    If Len(cell) = 0 Then
        If rngWOWO Is Nothing Then Set rngUnion = cell Else Set rngUnion = Union(cell, rngUnion)
    End If
Next
rngWOWO.Delete
   
Application.CutCopyMode = False
Application.Goto Worksheets("Extract").Range("A1"), True
   
End Sub

 

[JTC1234]

I see that you have variables not used and also some codes doing nothing. Maybe you were writing while thinking what to do next. Yes ... I did that too from time to time because doing things on the spot ?

I rewrote the code, delete several lines which I think were doing nothing and modify few line. I hope this works. No data to test.... Let me know

Private Sub CommandButton1_Click()

Dim eRow As Long, a As Long
Dim ws As Worksheet, wsExtract As Worksheet
  
Set wsExtract = ActiveWorkbook.Sheets("Extract")
  
wsExtract.AutoFilterMode = False

'PURPOSE: Loop through all visible sheets and copy designated data into sheet Extract
For Each ws In Sheets
    If ws.Name <> "Original" And ws.Visible = True Then
        a = wsExtract.Cells(Rows.Count, 2).End(xlUp).Row + 1      'Get the next empty row
        wsExtract.Range("A" & a) = ws.Name
        ws.Range("c10:w43").Copy        'Copy row on sheet1 meeting criteria
        wsExtract.Range("B" & a).PasteSpecial (xlPasteValuesAndNumberFormats)       'Paste data in Sheet2
        a = a + 1
          
        ws.Range("c47:w80").Copy        'Copy row on sheet1 meeting criteria
        wsExtract.Range("B" & a).PasteSpecial (xlPasteValuesAndNumberFormats)       'Paste data in Sheet2
        a = a + 1
          
        ws.Range("c84:w114").Copy        'Copy row on sheet1 meeting criteria
        wsExtract.Range("B" & a).PasteSpecial (xlPasteValuesAndNumberFormats)       'Paste data in Sheet2
    End If
Next ws
  
'PURPOSE: Delete any rows without WO#
Dim rngData As Range, rngWOWO As Range

' Find end of row on Sheet Exctract refering to column B
eRow = Worksheets("Extract").Cells(Rows.Count, "B").End(xlUp).Row

' Set range of data with WO#
Set rngData = Worksheets("Extract").Range("C2", "C" & eRow)            ' Assuming range starts from row 2

For Each cell In rngData
    If Len(cell) = 0 Then
        If rngWOWO Is Nothing Then Set rngUnion = cell Else Set rngUnion = Union(cell, rngUnion)
    End If
Next
rngWOWO.Delete
  
Application.CutCopyMode = False
Application.Goto Worksheets("Extract").Range("A1"), True
  
End Sub

Zot,

Thanks for your assistance. Yes, I'm back getting acquainted with VBA for Excel. I'm going to give it a try. I'll keep you posted on the results.