VBA Copy split elements of vertically saved strings to another sheet in horizontal manner - string

Question

I am looking to save the vertically saved Information for each ID (row 1) from this Worksheet:
To another Worksheet, which Looks like this:
For each column, with the ID in row 1, there are skills saved as strings. Each part (there are 3) is supposed to be saved on the second Worksheet in column B,C and D, respectively.
With the code I will post below, there is no Error. It simply doesn't do anything. When using a stop in the code, the problem seems to be that the items ID's I am trying to find (FindIDcol, FindIDrow) are simply "Nothing".
I am very new to VBA and might have a way too complicated Approach or ineffective code. However, I hope one of you can help me out here.
Thank you in advance for your help!
Here my code:
Dim wsInput As Worksheet
Set wsInput = ActiveWorkbook.Worksheets("Supplier Skills")
Dim wsOutput As Worksheet
Set wsOutput = ActiveWorkbook.Worksheets("Search Skills")
Dim IDcolumn As Range
Dim IDrow As Range
Dim lastcol As Integer
Dim lastRow As Integer
Dim NextRow As Integer
Dim FindIDcol As Range
Dim FindIDrow As Range
With wsInput
lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
LastColLetter = Split(Cells(1, lastcol).Address(True, False), "$")(0)
'For every column on Input-Sheet with Data
For Each IDcolumn In wsInput.Range("A1:" & LastColLetter & "1")
'Firstly, find each ID column
FindIDcol = wsInput.Range("A1:" & LastColLetter & "1").Find(What:=IDcolumn, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not FindIDcol Is Nothing Then
'Secondly, get the respective column Letter
IDcolLetter = Split(FindIDcol.Address, "$")(0)
'Thirdly, find all skills saved in rows beneath this column
lastRow = .Range(IDcolLetter & .Rows.Count).End(xlUp).row
For Each IDrow In wsInput.Range(IDcolLetter & "1:" & IDcolLetter & lastRow)
'Fourthly, get the respective row-number for each skill
FindIDrow = wsInput.Range(IDcolLetter & "2:" & IDcolLetter & lastRow).Find(What:=IDrow, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
IDrowNumber = Split(FindIDrow.Address, "$")(1)
'Fifthly, split the strings in 3 parts
Dim myElements() As String
myElements = Split(wsInput.Range(IDcolLetter & IDrowNumber).value, "\")
'Sixthly, for every skill of that supplier, copy the ID in A, CG in B, Category in C and Product in D
NextRow = wsOutput.Range("A" & Rows.Count).End(xlUp).row + 1
wsInput.Range(IDcolLetter & "1").Copy Destination:=wsOutput.Range("A" & NextRow) 'ID
wsOutput.Range("B" & NextRow) = myElements(0) 'Commodity Group
wsOutput.Range("C" & NextRow) = myElements(1) 'Category
wsOutput.Range("D" & NextRow) = myElements(2) 'Product
Next IDrow
End If
Next IDcolumn
End With

Answer 1

standing your shown data structure and if I correctly interpreted your goal, you can simplify your code as follows:
Option Explicit
Sub main()
Dim wsOutput As Worksheet
Dim colCell As Range, rowCell As Range
Dim outputRow As Long
Set wsOutput = Worksheets("Output") '<--| change "Output" to your actual output sheet name
outputRow = 2 '<--| initialize output row to 2 (row 1 is for headers)
With Worksheets("Input") '<--| reference input sheet (change "Input" to your actual input sheet name)
For Each colCell In .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft)).SpecialCells(XlCellType.xlCellTypeConstants) '<--| iterate over its row 1 non blank cells
For Each rowCell In .Range(colCell.Offset(1), colCell.End(xlDown)) '<--| iterate over current column rows from row 2 down to last contiguous non empty one
wsOutput.Cells(outputRow, 1) = colCell.Value '<--| write ID in column 1 of current output row
wsOutput.Cells(outputRow, 2).Resize(, 3) = Split(rowCell.Value, "\") '<--| write other info from column 2 rightwards of current output row
outputRow = outputRow + 1 '<--| update output row
Next rowCell
Next colCell
End With
End Sub
should you deal with input sheet non contiguous data below any ID (blank cells) or ID with no data below, there would be needed a few changes