#excel #vba
#excel #vba
Вопрос:
Я использую приведенный ниже код для транспонирования и вставки строк для набора данных.
Он делает в основном то, что я хочу, но он непрерывно вставляет строки без учета данных, которые находятся слева от столбцов.
Sub TransposeInsertRows()
Dim rData As Range
Dim aData As Variant
Dim aResults() As Variant
Dim iyData As Long, ixData As Long
Dim iyResult As Long
On Error Resume Next
Set rData = Application.InputBox(Prompt:="Range Selection...", _
Title:="Transpose", _
Default:=Selection.Address, _
Type:=8)
On Error GoTo 0
If rData Is Nothing Then Exit Sub 'Pressed cancel
If rData.Cells.Count = 1 Then
MsgBox "Only one cell selected, not enough data to transpose and insert. Exiting Macro."
Exit Sub
End If
aData = rData.Value
ReDim aResults(1 To rData.Rows.Count * rData.Columns.Count, 1 To 2)
For iyData = 1 To UBound(aData, 1)
For ixData = 2 To UBound(aData, 2)
If Len(Trim(aData(iyData, ixData))) > 0 Then
iyResult = iyResult 1
aResults(iyResult, 1) = aData(iyData, 1)
aResults(iyResult, 2) = aData(iyData, ixData)
End If
Next ixData
Next iyData
If iyResult = 0 Then
MsgBox "No data found to transpose in selected range [" amp; rData.Address amp; "]"
Exit Sub
End If
rData.Clear
If rData.Rows.Count < iyResult Then
rData.Offset(1).Resize(iyResult - rData.Rows.Count - 1).EntireRow.Insert
End If
rData.Resize(iyResult, UBound(aResults, 2)).Value = aResults
End Sub Мои данные Excel выглядят следующим образом
Other Data | Data to transpose | Data to transpose |...
----------------------------------------------------------------------------------
xyz123 | telephone | 123 | 312 | 123 | 334|
oij | faxmachine | 129 | 22 | 3 |
lowks | fridge | 32 | 1 | 55 | 928| 239| Я хочу, чтобы это выглядело как
Other Data | Data to transpose | Data to transpose |...
----------------------------------------------------------------------------------
xyz123 | telephone | 123 |
| telephone | 312 |
| telephone | 123 |
| telephone | 334 |
oij | faxmachine | 129 |
| faxmachine | 22 |
| faxmachine | 3 |
lowks | fridge | 32 |
| fridge | 1 |
| fridge | 55 |
| fridge | 928 |
| fridge | 239 | В настоящее время я получаю следующее:
...Other Data | Data to transpose | Data to transpose |...
----------------------------------------------------------------------------------
xyz123 | telephone | 123 |
| telepone | 312 |
| telephone | 123 |
| telehone | 334 |
| faxmachine | 129 |
| faxmachine | 22 |
| faxmachine | 3 |
| fridge | 32 |
| fridge | 1 |
| fridge | 55 |
| fridge | 928 |
| fridge | 239 |
oij |
lowks | Мы высоко ценим вашу помощь!
Ответ №1:
Адаптация вашего кода — см. Добавленные комментарии.
Sub TransposeInsertRows()
Dim rData As Range
Dim aData As Variant
Dim aResults() As Variant
Dim iyData As Long, ixData As Long
Dim iyResult As Long
On Error Resume Next
Set rData = Application.InputBox(Prompt:="Range Selection...", _
Title:="Transpose", _
Default:=Selection.Address, _
Type:=8)
On Error GoTo 0
If rData Is Nothing Then Exit Sub 'Pressed cancel
If rData.Cells.Count = 1 Then
MsgBox "Only one cell selected, not enough data to transpose and insert. Exiting Macro."
Exit Sub
End If
aData = rData.Value
ReDim aResults(1 To rData.Rows.Count * rData.Columns.Count, 1 To 3) 'need 3 columns, not 2
iyResult = 1
For iyData = 1 To UBound(aData, 1)
aResults(iyResult, 1) = aData(iyData, 1) 'xyz123 etc moe outside loop so doesn't repeat every row
For ixData = 3 To UBound(aData, 2) 'start at 3, as 2 is telephone etc
If Len(Trim(aData(iyData, ixData))) > 0 Then
aResults(iyResult, 2) = aData(iyData, 2) 'telephone etc
aResults(iyResult, 3) = aData(iyData, ixData) 'numbers
iyResult = iyResult 1
End If
Next ixData
Next iyData
If iyResult = 0 Then
MsgBox "No data found to transpose in selected range [" amp; rData.Address amp; "]"
Exit Sub
End If
rData.Clear
If rData.Rows.Count < iyResult Then
rData.Offset(1).Resize(iyResult - rData.Rows.Count - 1).EntireRow.Insert
End If
rData.Resize(iyResult, UBound(aResults, 2)).Value = aResults
End Sub
Комментарии:
1. Я вижу, что вы сделали, дело в том, что в моих данных более 100 столбцов, когда я выбираю, что транспонировать, я выбираю только те столбцы, которые я хочу транспонировать. Но когда я это делаю, это не учитывает какие-либо данные, оставшиеся от выделения. С вашим кодом у меня получилось 3 столбца, в которых в 1-м столбце был интервал, который я хочу для всех данных слева от моего выделения. Мне нравится, чтобы в моем конечном выводе было 2 столбца. 1, в котором есть телефон, 2, в котором есть номера, в то время как данные вставлены с учетом остальных данных слева от моего выбора.
2. Хорошо, я предположил, что вы выбрали весь диапазон. Учитывая это, насколько я вижу, это приводит к результату, указанному вами выше.
Ответ №2:
Мое большое предположение заключается в том, что вы можете сделать это как второй лист, не касаясь ваших исходных данных и отрицая необходимость вставки строк …. что-то вроде:
dim sws as worksheet, dws as worksheet, i as long, j as long, k as long, slr as long, dlr as long, lc as long
set sws = sheets("source")
set dws = sheets("desination")
with sws
slr = .cells(.rows.count,2).end(xlup).row
for i = 1 to slr
lc = .cells(i,.columns.count).end(xltoleft).column
j = 3
dlr = dws.cells(dws.rows.count,2).end(xlup).row 1
dwb.cells(j,1)
do until j = lc
dwb.cells(dlr,2).value = .cells(i,2).value
dwb.cells(dlr,3).value = .cells(i,j).value
j = j 1
dlr = dlr 1
loop
next i
end with
Общая вещь, которую я делаю, — это вложение цикла для создания новой таблицы на листах («назначение») на основе данных в листах («источник»), где вы выполняете цикл, выполняя значение = значение для количества столбцов (после нахождения последнего столбца на исходном листе), что является циклом do-until. После того, как вы учтете все столбцы (которые станут строками на втором листе), вы переходите к следующей строке на исходном листе.
Правка1:
Хотя и не тестировался, оглянулся назад и не учел последнюю строку назначения (dlr) и добавил это в код.
Комментарии:
1. Кстати, вы также можете найти последний столбец в строке (lc в моем коде) и использовать его для вставки нескольких строк.