Скажите пожалуйста, возможно ли модифицировать этот макрос таким образом, чтобы при переносе данных в плоскую таблицу сохранялось форматирование ячейки, а именно цвет заливки и комментарии?
Файл прикладываю.
Спасибо! С уважением, Михаил
Добрый вечер!
Скажите пожалуйста, возможно ли модифицировать этот макрос таким образом, чтобы при переносе данных в плоскую таблицу сохранялось форматирование ячейки, а именно цвет заливки и комментарии?
Нашел похожее решение, но оно работает только для одномерной таблицы и транспонирует строку не полностью, а до последнего ненулевого значения в строке.
[vba]
Код
Sub unpivot() 'Set your variables Dim w1 As Worksheet Dim w2 As Worksheet Dim i As Long Dim lrS As Long Dim lrT As Long Set w1 = Sheets("Sheet1") Set w2 = Sheets("Sheet2") lrS = w1.Range("A" & Rows.Count).End(xlUp).Row Dim lc As Long 'new line lc = Cells(1, Columns.Count).End(xlToLeft).Column 'new line
Application.ScreenUpdating = False 'sets screen to update after all is completed so screen does not flutter With w1 'work within sheet1 For i = 2 To lrS 'sets variable to select rows 2 to last row and loop lrT = w2.Range("B" & Rows.Count).End(xlUp).Row 'sets the last row in the target worksheet .Range("A" & i).Copy w2.Range("A" & lrT + 1) 'copies the range A and row i (variable) to new sheet and places in row after last row .Range(Cells(i, 2), Cells(i, lc)).Copy 'changed copies range B to last column in variable row w2.Range("B" & lrT + 1).PasteSpecial xlPasteAll, , , True 'pastes to column B in target sheet .Range(Cells(1, 2), Cells(1, lc)).Copy 'changed copies range B1 to last column in row 1 w2.Range("C" & lrT + 1).PasteSpecial xlPasteAll, , , True 'pastes to column C in target sheet Next i End With Application.CutCopyMode = False
With w2 'using the target sheet lrT = .Range("B" & Rows.Count).End(xlUp).Row 'finds last row used in column B For i = 3 To lrT 'Sets loop If .Range("A" & i) = "" Then 'if range A and variable row is empty .Range("A" & i) = .Range("A" & i - 1) 'then copy the value in cell above and paste to it End If Next i End With Application.ScreenUpdating = True MsgBox "complete"
End Sub
[/vba]
Подскажите пожалуйста, как можно скорректировать код, чтобы можно было выбрать размерность таблицы (кол-во строк сверху и слева) и строка копировалась в столбец полностью?
С уважением, Михаил
Нашел похожее решение, но оно работает только для одномерной таблицы и транспонирует строку не полностью, а до последнего ненулевого значения в строке.
[vba]
Код
Sub unpivot() 'Set your variables Dim w1 As Worksheet Dim w2 As Worksheet Dim i As Long Dim lrS As Long Dim lrT As Long Set w1 = Sheets("Sheet1") Set w2 = Sheets("Sheet2") lrS = w1.Range("A" & Rows.Count).End(xlUp).Row Dim lc As Long 'new line lc = Cells(1, Columns.Count).End(xlToLeft).Column 'new line
Application.ScreenUpdating = False 'sets screen to update after all is completed so screen does not flutter With w1 'work within sheet1 For i = 2 To lrS 'sets variable to select rows 2 to last row and loop lrT = w2.Range("B" & Rows.Count).End(xlUp).Row 'sets the last row in the target worksheet .Range("A" & i).Copy w2.Range("A" & lrT + 1) 'copies the range A and row i (variable) to new sheet and places in row after last row .Range(Cells(i, 2), Cells(i, lc)).Copy 'changed copies range B to last column in variable row w2.Range("B" & lrT + 1).PasteSpecial xlPasteAll, , , True 'pastes to column B in target sheet .Range(Cells(1, 2), Cells(1, lc)).Copy 'changed copies range B1 to last column in row 1 w2.Range("C" & lrT + 1).PasteSpecial xlPasteAll, , , True 'pastes to column C in target sheet Next i End With Application.CutCopyMode = False
With w2 'using the target sheet lrT = .Range("B" & Rows.Count).End(xlUp).Row 'finds last row used in column B For i = 3 To lrT 'Sets loop If .Range("A" & i) = "" Then 'if range A and variable row is empty .Range("A" & i) = .Range("A" & i - 1) 'then copy the value in cell above and paste to it End If Next i End With Application.ScreenUpdating = True MsgBox "complete"
End Sub
[/vba]
Подскажите пожалуйста, как можно скорректировать код, чтобы можно было выбрать размерность таблицы (кол-во строк сверху и слева) и строка копировалась в столбец полностью?
Можно, хоть и сложно . Постарался оптимизировать скорость, путем копирования полных справочников и строк - а не отдельно каждой ячейки. Но при работе с диапазонами - все равно долго.
Можно, хоть и сложно . Постарался оптимизировать скорость, путем копирования полных справочников и строк - а не отдельно каждой ячейки. Но при работе с диапазонами - все равно долго.