Copy Sheet Name along with corresponding data.

JTC1234

New Member
Joined
Mar 7, 2021
Messages
4
Office Version
  1. 2007
Platform
  1. Windows
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
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
1,192
Office Version
  1. 2016
Platform
  1. Windows
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

New Member
Joined
Mar 7, 2021
Messages
4
Office Version
  1. 2007
Platform
  1. Windows
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

Well-known Member
Joined
Nov 26, 2020
Messages
1,192
Office Version
  1. 2016
Platform
  1. Windows
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

VBA Code:
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
 
Last edited:

JTC1234

New Member
Joined
Mar 7, 2021
Messages
4
Office Version
  1. 2007
Platform
  1. Windows
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

VBA Code:
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,130,220
Messages
5,640,962
Members
417,183
Latest member
CuteLeo

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top