Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel (архив)
Страницы: 1
RSS
Транспонирование вертикальных ячеек (подскажите)
 
#1
29.11.2010 18:17:34
Доброе время суток.  
Подскажите пожалуйста как реализовать следующее.  
Есть выгрузка из 1С.  
Надо транспонировать столбец D из вертикального положения в горизонтальный.  
В таком виде, как это приведено в файле.  
Исходная таблица начинается со столбца A до J  
Хочется чтобы столбец D раскладывался так, как показано на примере начиная со столбца M.  
 
Хочется этот процесс автоматизировать, т.к исходный файл постоянно обновляется (не структура, но содержимое).  
Спасибо заранее
 
 
 
#2
29.11.2010 18:18:38
{quote}{login=And_2010}{date=29.11.2010 06:17}{thema=Транспонирование вертикальных ячеек (подскажите)}{post}Доброе время суток.  
Подскажите пожалуйста как реализовать следующее.  
Есть выгрузка из 1С.  
Надо транспонировать столбец D из вертикального положения в горизонтальный.  
В таком виде, как это приведено в файле.  
Исходная таблица начинается со столбца A до J  
Хочется чтобы столбец D раскладывался так, как показано на примере начиная со столбца M.  
 
Хочется этот процесс автоматизировать, т.к исходный файл постоянно обновляется (не структура, но содержимое).  
Спасибо заранее{/post}{/quote}
 
 
 
#3
29.11.2010 21:11:48
Option Explicit  
 
Sub tt()  
Dim a(), b(), i As Long, ii As Long, iii As Long  
a = [c8:d28].Value
ReDim b(1 To UBound(a, 1), 1 To 10) 'если 10 мало, можно поставить и 100 :)  
 
For i = 1 To UBound(a, 1)  
If a(i, 1) <> "" Then ii = i: iii = 0  
iii = iii + 1  
b(ii, iii) = a(i, 2)  
Next  
 
[m8].Resize(UBound(b, 1), UBound(b, 2)).Value = b 'выгружаем результат
 
End Sub
 
 
 
#4
29.11.2010 21:13:55
Проверьте. Есть небольшая проблема с концовкой таблицы. Если заметите - будем думать, как исправить :-)
 
 
 
#5
29.11.2010 23:13:39
"Полумассивное" решение  
 
Sub And_2010()  
Dim i As Long  
i = 8  
Do Until Cells(i, "D") = ""  
   Cells(i, "M").Resize(, 4) = Application.Transpose(Cells(i, "D").Resize(4))  
   i = i + 4  
Loop  
End Sub
 
 
 
#6
29.11.2010 23:33:11
{quote}{login=Казанский}{date=29.11.2010 11:13}{thema=}{post}i = i + 4{/post}{/quote}  
Казанский, там не всегда 4.
 
 
 
#7
30.11.2010 00:19:09
Юрий, что ты такой вредный? ;)  
 
Sub And_2010()  
Dim iLastRow As Long, r As Range, r1 As Range  
iLastRow = Cells(Rows.Count, "D").End(xlUp).Row + 1  
Set r = Range("B8")  
Do Until IsEmpty®  
If IsEmpty(r.Offset(1)) Then Set r1 = r.End(xlDown) Else Set r1 = r.Offset(1)  
If r1.Row > iLastRow Then Set r1 = Range("B" & iLastRow)  
r.Offset(, 11).Resize(, r1.Row - r.Row) = Application.Transpose(Range(r, r1.Offset(-1)).Offset(, 2))  
Set r = r1  
Loop  
End Sub
 
 
 
#8
30.11.2010 00:24:01
Чуть что - сразу Юрий. Зануда я, потому что :-)
 
 
 
#9
30.11.2010 12:04:58
{quote}{login=Казанский}{date=30.11.2010 12:19}{thema=}{post}Юрий, что ты такой вредный? ;)  
 
Sub And_2010()  
Dim iLastRow As Long, r As Range, r1 As Range  
iLastRow = Cells(Rows.Count, "D").End(xlUp).Row + 1  
Set r = Range("B8")  
Do Until IsEmpty®  
If IsEmpty(r.Offset(1)) Then Set r1 = r.End(xlDown) Else Set r1 = r.Offset(1)  
If r1.Row > iLastRow Then Set r1 = Range("B" & iLastRow)  
r.Offset(, 11).Resize(, r1.Row - r.Row) = Application.Transpose(Range(r, r1.Offset(-1)).Offset(, 2))  
Set r = r1  
Loop  
End Sub{/post}{/quote}  
 
Казанский - спасибо огромное все работает.  
Но выдает ошибку в строке    
r.Offset(, 11).Resize(, r1.Row - r.Row) = Application.Transpose(Range(r, r1.Offset(-1)).Offset(, 2))  
 
А так результат выводиться замечательно.  
Хотя на примере не выдает ошибку, а на реальном файле выдает - может из за большого кол-ва строк?  
Там их около 2000
 
 
 
#10
30.11.2010 12:49:58
Какая версия Экселя?  
На 2000 вполне Transpose может глючить.
 
 
 
#11
01.12.2010 09:49:13
{quote}{login=Hugo}{date=30.11.2010 12:49}{thema=}{post}Какая версия Экселя?  
На 2000 вполне Transpose может глючить.{/post}{/quote}  
 
Версия Excel 2007
 
 
 
Страницы: 1
Читают тему
Наверх