Trying to copy current worksheet name

[joostpost198]

I want to copy the workbook and worksheet name from the old into a new excel on every row of the first column. the vba text i have now is:

Public Sub get_spec_data()

Dim ws As Worksheet
Dim ws_d As Worksheet
Dim r_d As Long
Dim c_d As Long
Dim r As Long


Set ws = Workbooks("NG4A-DA-ITTDS-CD30195.xls").Worksheets("LC")
Set ws_d = ThisWorkbook.Worksheets("Spec_data")

ws.Activate

Debug.Print ws.Name
Debug.Print ws.PageSetup.PrintArea

r_d = 1
c_d = 1
r = 1

For Each c In ws.Range(ws.PageSetup.PrintArea).Cells
Debug.Print c.Address, c.Row, c.Value, r, Columns(c.Column).Hidden

If Trim(c.Value) <> "" And Not Columns(c.Column).Hidden Then
Debug.Print "Ja ik heb een niet lege cell gevonden"


If c.Row = r Then
c_d = c_d + 1
Else
r_d = r_d + 1
c_d = 2
End If

ws_d.Cells(r_d, c_d).Value = c.Value
End If



r = c.Row
Next


End Sub

[patel]

I did not understand your goal

[joostpost198]

i just want to copy the name of the excel in a new excel sheet

[patel]

[vba]Sub get_name()
Set ws = Workbooks("NG4A-DA-ITTDS-CD30195.xls").Worksheets(1)
Set ws_d = ThisWorkbook
wbname = ws_d.Name
ws.Range("A1") = wbname
End Sub[/vba]

[snb]

Nou dan gebruik je toch gewoon

[VBA]M_snb()
with Workbooks("NG4A-DA-ITTDS-CD30195.xls").Worksheets("LC")
thisworkbook.sheets("spec_data").cells(1,1)=.parent.name & "_" & .name
End With
End Sub[/VBA]

[SamT]

Only the names have been changed and comments added.
[vba]Option Explicit

Public Sub get_spec_data()

Dim NG4ASht As Worksheet
Dim SpecDataSht As Worksheet
Dim SpecDataRow As Long
Dim SpecDataCol As Long
Dim Rw As Long
Dim Cel As Range

Set NG4ASht = Workbooks("NG4A-DA-ITTDS-CD30195.xls").Worksheets("LC")
Set SpecDataSht = ThisWorkbook.Worksheets("Spec_data")

SpecDataRow = 1
SpecDataCol = 1

Rw = 1
For Each Cel In NG4ASht.Range(NG4ASht.PageSetup.PrintArea).Cells
If Trim(Cel.Value) <> "" And Not Columns(Cel.Column).Hidden Then

'Why Test For Row?
If Cel.Row = Rw Then 'Only posssible to match on Rw=1. See Below.

'copy non empty visible cells into SpecDataRow until first hidden column
SpecDataCol = SpecDataCol + 1
Else 'Hidden Column. Next SpecDataRow, and back to SpecDataCol 2
SpecDataRow = SpecDataRow + 1
SpecDataCol = 2
End If

SpecDataSht.Cells(SpecDataRow, SpecDataCol).Value = Cel.Value
End If

Rw = Cel.Row 'At Top of loop, next Cel.Row will be below Row(Rw)
'Try
'Rw = Cel.Row + 1
Next
End Sub
[/vba]