Insert new column and paste (Shortened) workbook name down to last cell

[Manerlao]

Hi all!

I have a problem which is really troubling me! If someone could please help, I would really appreciate it!

Overview:

I have a range of different workbooks which I need to insert a new column to and include a specific ID which is based on the specific workbook name.3

Objective:

- Insert new column in B:B with name ID_Name in B1 (I have this code already)
- Paste the name of the workbook from cell B2:Last cell in that column (But I want to paste a shortened name of the workbook). (The challenge for me)

My workbooks all have the name structure: ABCD_File_Date_Version or ABCDE_File_Date_Version or ABCDEF_File_Date_Version
So I just want to paste everything before the underscore '_' for that specific workbook when I run the macro.
i.e. I just need ABCD or ABCDE or ABCDEF depending on the file.

My code is in my personal macro workbook, and it works very well so far, but I can't get it to paste the name of the workbook according to my requirement.

Here is my code so far:

Sub AddCol()
'Add a new column in B:B with ID_Name

Dim ws As Worksheet
Dim lastRow As Long

lastRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row

If Range("B1") = "ID_Name" Then
Else
For Each ws In ActiveWorkbook.Sheets

ws.Range("B:B").EntireColumn.Insert
ws.Range("B1").Value = "ID_Name"

With ws
.Range(Cells(1, 2), Cells(lastRow, 1)).Value = ActiveWorkbook.Name
End With

    With ThisWorkbook.Worksheets
        ws.Range("B:B").NumberFormat = "Text"
    End With

Next ws
End If
        
End Sub

If anyone has some ideas, please let me know.

Thank you Excel Community!

 

[Manerlao]

[UPDATE]
Hi all, just an update to my code!

This works really well to:
Insert new column
Paste workbook name

Sub AddColTEST()
'Add a new column in B:B with ID_Name

Dim ws As Worksheet
Dim Formulas(1) As Variant
Dim lastRow As Long

If Range("B1") = "ID_Name" Then
'Nothing

Else
For Each ws In ActiveWorkbook.Sheets
ws.Activate

With ws
lastRow = .Cells(Rows.Count, 2).End(xlUp).Row

.Range("B:B").EntireColumn.Insert
.Range("B1").Value = "ID_Name"
.Range(Cells(2, 2), Cells(lastRow, 2)).Value = ActiveWorkbook.Name

End With

Next ws
End If
        
End Sub

but now I need to figure out how to paste a shortened name of the workbook.name.

Any ideas? thank you all!

 

[Fluff]

How about

Sub Manerlao()
   Dim Ws As Worksheet
   Dim WbkName As String
   
   If Range("B1") <> "ID_Name" Then
      WbkName = Split(ActiveWorkbook.Name, "_")(0)
      For Each ws In ActiveWorkbook.Worksheets
         ws.Range("B:B").EntireColumn.Insert
         ws.Range("B1").Value = "ID_Name"
         ws.Range("B2:B" & ws.Range("A" & Rows.Count).End(xlUp).Row).Value = WbkName
         ws.Range("B:B").NumberFormat = "Text"
      Next ws
   End If
End Sub

 

[Manerlao]

Hi again Fluff! I hope you have been well.

Thank you so much, that worked a real charm!

Also, I just realized I can also write ..... Left(ActiveWorkbook.Name, 4)
But my code isn't as clean and dynamic as the one you have kindly written! Even my name is in the Sub :D

Thanks you so much again!

Best regards,
M.

 

[Fluff]

You're welcome & thanks for the feedback.