Vba-excel change change value of a cell depending on worksheet name-CodePudding

Hi I am trying to learn vba and I have this list. For every NAME there will be an individual worksheet created. If the name of the worksheet match the name on the list i need to put the length in cell J1. I tried to use if elseif but knowing i have 430 different names the code will be too long what should i do? What alternative code can i use?

Sub length()

Dim ws As Worksheet



For Each ws In ThisWorkbook.Worksheets
    
If ws.Name = "A" Then
ws.Activate
Range("J1").Select
ActiveCell.FormulaR1C1 = 4153

ElseIf ws.Name = "B" Then
    ws.Activate
    Range("J1").Select
    ActiveCell.FormulaR1C1 = 2273
    
Next
MsgBox "DONE"
End Sub

enter image description here

CodePudding user response：

Assuming that the columns are as on the image, you can do this:

Sub fnPickLength()

    Dim ws As Excel.Worksheet
    Dim oCell As Excel.Range
    Dim oRng As Excel.Range

    Set oRng = Range("rngTheNames") 'name the range with this name

    For Each ws In ThisWorkbook.Worksheets
        For Each oCell In oRng
            If UCase(ws.Name) = UCase(oCell.Value) Then
                ws.Activate
                Range("J1").Select
                ActiveCell.FormulaR1C1 = oCell.Offset(0, 1).Value
                Exit For
            End If
        Next
    Next

    MsgBox "DONE"
End Sub

Please adapt the named range as you want. I've choosen as "rngTheNames". The ws name is compared with each oCell value. If matched, the Offset property reads the sibling cell of the evaluated name and put its value on the ws.

CodePudding user response：

Sub length()
Dim Cell as Range
    For Each Cell In Range("Name")   
        On Error Resume Next
        ThisWorkbook.Sheets(Cell.Value).Range("J1") = Cell.Offset(0, 1)
        If Err.Number <> 0 Then Debug.Print "Sheet " & Cell & " wasn't found"
        On Error GoTo 0
    Next Cell
    MsgBox "DONE"
End Sub

Range("Name") needs to be changed to refer to the real range with the sheet names.
On Error ... can be removed if you're sure that all mentioned worksheets exist.

CodePudding user response：

Write Values to Worksheets From a List

This will loop through the list of names. There may be worksheets whose names are not on the list.
Adjust the name of the worksheet containing the list (Sheet1) and the column (A) and row (2) of the first name.

Option Explicit

Sub CopyLengths()

    ' Reference the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source worksheet ('sws').
    Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
    ' Calculate the last row ('slRow'), the row of the last non-empty cell
    ' in the worksheet names column.
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
    ' Reference the source range ('srg'), the one-column range
    ' containing the worksheet names.
    Dim srg As Range: Set srg = sws.Range("A2", sws.Cells(slRow, "A"))

    Dim dws As Worksheet ' Destination Worksheet
    Dim sCell As Range ' Current Source (Name) Cell
    Dim sString As String ' Current Source String
    
    ' Copy lenghts.
    
    ' Loop through the cells ('sCell') of the source range...
    For Each sCell In srg.Cells
        ' Convert the current cell's value to a string ('CStr')
        ' and write the string to a variable ('sString').
        sString = CStr(sCell.Value)
        ' Check if the string is not an empty string...
        If Len(sString) > 0 Then ' the cell is not blank
            ' Attempt to reference the worksheet named after the string.
            On Error Resume Next
                Set dws = wb.Worksheets(sString)
            On Error GoTo 0
            If Not dws Is Nothing Then ' worksheet found (referenced)
                ' Copy (write) the length.
                dws.Range("J1").Value = sCell.Offset(, 1).Value
                Set dws = Nothing ' reset the variable
            'Else ' worksheet not found (not referenced); do nothing or e.g. ...
                'Debug.Print "Worksheet '" & sString & "' not found"
            End If
        'Else ' the cell is blank; do nothing
        End If
    Next sCell
            
    ' Inform.
    MsgBox "Lengths copied.", vbInformation
    
End Sub