VBAコピーは、私は、このワークシートから各ID（行1）のために縦に保存された情報を保存するために探しています水平に別のシートに

Question

を縦に保存された文字列の要素を分割しましたこのように見えた：各列について

、行1内のIDと、文字列として保存された技術があります。各パート（3つあります）は、それぞれB、C、Dの2番目のワークシートに保存されています。

以下のコードでは、エラーはありません。それは単に何もしません。コードで停止を使用する場合、問題は、私が見つけようとしているアイテムID（FindIDcol、FindIDrow）が単に "Nothing"であるように見えます。

私はVBAの新機能であり、複雑すぎるアプローチや無効なコードがある可能性があります。しかし、皆さんのお役に立てれば幸いです。

ありがとうございました！

ここに私のコード：

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

はあなたのようなデータ構造を立って、私が正しくあなたの目標を解釈する場合は、次のように、あなたのコードを簡素化することができます

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 

あなたが入力に対処する必要があります以下のデータがないID（空白のセル）またはIDの下の非シートの連続していないデータ