Excel VBA Macro – отдельное содержимое ячеек в пространстве пробелами в строки и захват исходного местоположения ячейки

У меня есть таблица запасов, которая имеет несколько записей на ячейку, разделенных пробелами. Они используют текущую ячейку в качестве ссылочного номера, поэтому мне нужно поддерживать эту информацию.

Пример:
Текущий

Cell A1 - PartA PartB PartC Cell A2 - PartD PartE 

Желаемый

 Cell A1 - PartA Cell B1 - A 'OriginalColumn Cell C1 - 1 'OriginalRow Cell A2 - PartB Cell B2 - A 'OriginalColumn Cell C2 - 1 'OriginalRow Cell A3 - PartC Cell B3 - A 'OriginalColumn Cell C3 - 1 'OriginalRow Cell A4 - PartD Cell B4 - A 'OriginalColumn Cell C4 - 2 'OriginalRow Cell A5 - PartE Cell B5 - A 'OriginalColumn Cell C5 - 2 'OriginalRow 

и т.п.

Я сделал свое исследование, и ближайший код VBA делится информацией, но он вставляет его в следующую строку, и для диапазона это не подходит для меня. SO: разделенные запятыми строки

Я пробовал изменить код, чтобы он работал для диапазона, но с трудностями заставить его работать и не уверен, что случилось. Мне также трудно найти, как захватить исходное местоположение ячейки и вывести ее в другие строки. (Если его нельзя разделить от A1 до A & 1, я могу жить с этим, но это желательно.)

Заранее благодарим за помощь в указании пути!

Текущий код:

  Option Explicit Sub ToolFormat() Dim mainsheet As Sheet1 Dim datalist As Sheet2 Dim vLastRow As Long Dim vLastCol As Long Dim y As Long Dim x As Long With ActiveSheet.UsedRange vLastRow = .Rows(.Rows.Count).Row vLastCol = .Columns(.Columns.Count).Column End With ' MsgBox ("Last row: " & vLastRow & " Last column: " & vLastCol) Dim toCol As String Dim toRow As String Dim inVal As Range Dim outVal As Range Dim commaPos As Integer Set inVal = Nothing For y = 1 To vLastCol For x = 1 To vLastRow ' Copy from mainsheet range to datalist column B.' toCol = "B" toRow = "1" ' Go until no more entries inVal = mainsheet.Cells(x, y).Value While inVal <> "" ' Go until all sub-entries used up.' While inVal <> "" Range(y + x).Select ' Extract each subentry.' commaPos = InStr(1, inVal, ",") While commaPos <> 0 ' and write to output column.' outVal = Left(inVal, commaPos - 1) datalist.Range(toCol + toRow).Select datalist.Range(toCol + toRow).Value = outVal toRow = Mid(Str(Val(toRow) + 1), 2) ' Remove that sub-entry.' inVal = Mid(inVal, commaPos + 1) While Left(inVal, 1) = " " inVal = Mid(inVal, 2) Wend commaPos = InStr(1, inVal, ",") Wend ' Get last sub-entry (or full entry if no commas).' Range(toCol + toRow).Select Range(toCol + toRow).Value = inVal toRow = Mid(Str(Val(toRow) + 1), 2) inVal = "" Wend ' Advance to next source row.' x = Mid(Str(Val(x) + 1), 2) mainsheet.Range(y + x).Select inVal = mainsheet.Range(y + x).Value Wend Next x ' until x.value = "" Next y End Sub 

Этот код должен делать то, что вы хотите (надеюсь):

 Sub SplitIt() Dim rng As Range Set rng = Sheets("Sheet1").Range("A1:A10") 'change that as you need it (the data to be splited) Dim rngVal As Variant rngVal = rng.Value Dim xSpl As Variant, xSpl2 As Variant, xVal() As Variant, i As Long, j As Long, col As String j = rng.Row col = Split(Columns(rng.Column).Address(, 0), ":")(0) ReDim xVal(1 To 3, 0) For Each xSpl In rngVal If Len(xSpl) Then xSpl = Split(Trim(xSpl), " ") If UBound(xVal, 2) Then ReDim Preserve xVal(1 To 3, 1 To i + UBound(xSpl) + 1) Else ReDim xVal(1 To 3, 1 To UBound(xSpl) + 1) End If For Each xSpl2 In xSpl If Len(xSpl2) Then i = i + 1 xVal(1, i) = xSpl2 xVal(2, i) = col xVal(3, i) = j End If Next End If j = j + 1 Next Sheets("Sheet2").Range("A1").Resize(i, 3) = Application.Transpose(xVal) 'Change the sheet and the "A1" to the upper left cell to output to End Sub 

он предназначен для работы только для одного столбца с несколькими строками, но не использует диапазон, такой как «A: A» (только диапазон, который содержит значения), или он может заморозить превосходство в течение некоторого времени;)

Как это работает:

Он проверяет каждую ячейку в диапазоне, если в ней есть что-либо внутри (пробелы будут пропущены, а также ячейки, содержащие пробелы).
Затем каждое значение ячейки разбивается на массив (разделяется пробелом). Этот массив будет привязан к существующему массиву output (опять же, пустые части будут пропущены).

Благодаря тому, как работает Redim Preserve , мы получаем транспонированный массив, который нам нужно транспонировать в конце для вывода. И это все … (часть для столбца / строки должна быть самообучающейся)

Если у вас все еще есть вопросы, просто спросите;)

Interesting Posts

Повышение эффективности с помощью вложенных циклов и сравнения массивов

Можно ли имитировать строки excel на другом листе?

Ошибка Python: IndexError: не может выполнить непустой выбор из пустых осей

Excel VBA Найти значение в столбце и выполнить математику

Почему формулы массива Excel замедляются?

Excel VBA более эффективен

Inno Setup – Регистрация компонентов в качестве администратора

Создание пользовательской функции Excel для сопоставления синонимов из списка

Получение ошибки несоответствия типа

В VBA, как проверить, посылает ли гиперссылка данные?

Копировать и вставить значения после фильтрации на основе значения на другом листе

Формулы в VBA, которые включают переменные

Функции для преобразования SQL в строки VBA

confluence, excel macro: пробелы в импортированном файле excel разбивают ячейки в слиянии созданного документа

Написание функции по формуле

Давайте будем гением компьютера.