Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 05.04.2018, 09:58   #1
ДаниилФ
Новичок
Джуниор
 
Регистрация: 05.04.2018
Сообщений: 4
По умолчанию Перенос нескольких столбцов строчки 1 в аналогичное количество строчек с сохранением значения первого столбца строчки 1

Помогите пожалуйста, нужно сделать автоматизацию для большого массива данных (более 1000 строчек), вручную займёт очень много времени, так как данные могут меняться.
Нужна рабочая формула или ссылка на аналогичную тему.
В примере из данных "А" нужен результат "В".
Спасибо !
Вложения
Тип файла: xlsx Пример.xlsx (9.9 Кб, 29 просмотров)

Последний раз редактировалось ДаниилФ; 05.04.2018 в 10:20.
ДаниилФ вне форума Ответить с цитированием
Старый 05.04.2018, 11:00   #2
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

Вывод на "Лист3"
Код:
Option Explicit

Sub DoWork()
    Dim r  As Integer
    r = 2
    Dim arrC() As String
    Dim rCount As Integer
    Dim i As Integer
    rCount = 2
    With Sheets("Лист1")
       Do While .Cells(r, "A") <> ""
        arrC = Split(Trim(.Cells(r, "C")), " ")
        For i = LBound(arrC) To UBound(arrC)

            Sheets("Лист3").Cells(rCount, "A") = .Cells(r, "A")
            Sheets("Лист3").Cells(rCount, "B") = .Cells(r, "B")
            Sheets("Лист3").Cells(rCount, "C") = arrC(i)
            rCount = rCount + 1
        Next i
        r = r + 1
       Loop
    End With
End Sub
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 05.04.2018, 15:21   #3
ДаниилФ
Новичок
Джуниор
 
Регистрация: 05.04.2018
Сообщений: 4
По умолчанию

В LibreOffice не работает, пишет:

Ошибка времени выполнения BASIC.
Подпрограмма или функция не определена.
ДаниилФ вне форума Ответить с цитированием
Старый 05.04.2018, 15:25   #4
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

Цитата:
Сообщение от ДаниилФ Посмотреть сообщение
В LibreOffice не работает, пишет:
могу и там сделать, но если "вот прям счас", то вам на forumooo.ru спросите JohnSUN
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 05.04.2018, 15:50   #5
ДаниилФ
Новичок
Джуниор
 
Регистрация: 05.04.2018
Сообщений: 4
По умолчанию

Спасибо, в Excel всё работает !
ДаниилФ вне форума Ответить с цитированием
Старый 05.04.2018, 15:51   #6
ДаниилФ
Новичок
Джуниор
 
Регистрация: 05.04.2018
Сообщений: 4
По умолчанию

Если не сложно для Libre, я буду очень счастлив !
ДаниилФ вне форума Ответить с цитированием
Старый 05.04.2018, 16:20   #7
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

Код:
Sub Main
	dim RowCount as long
	dim RowCount3 as long
	dim celC as string
	dim celA as string
	oSheet1=ThisComponent.Sheets.getByName("Лист1") ' получения активного листа
	oSheet3=ThisComponent.Sheets.getByName("Лист3") ' получения активного листа
	RowCount = LastRowWithData("Лист1")+1
	RowCount3 = 1
	for r = 1 to RowCount
		celA = oSheet1.getCellByPosition(0,r).string
		if oSheet1.getCellByPosition(0,r).string <> "" then
		celC = trim(oSheet1.getCellByPosition(2,r).string)	
		arrC = Split(celC," ")
			for i = LBound(arrC) to UBound(arrC)
				oSheet3.getCellByPosition(0,RowCount3).string = oSheet1.getCellByPosition(0,r).string
				oSheet3.getCellByPosition(1,RowCount3).string = oSheet1.getCellByPosition(1,r).string
				oSheet3.getCellByPosition(2,RowCount3).string = arrC(i)
				RowCount3 = RowCount3 + 1
			next i
		end if 	
	next r
	
End Sub

Function LastRowWithData (SheetName  as string) as long
   Dim oCursor As Object, oRange As Object, oSheet As Object
   Dim LastRowOfUsedArea as long, R as long
   Dim RangeData

   oSheet = ThisComponent.Sheets.getByName(SheetName)
   oCursor = oSheet.createCursor
   oCursor.gotoEndOfUsedArea(False)
   LastRowOfUsedArea = oCursor.RangeAddress.EndRow
   oRange = oSheet.getCellRangeByPosition(0, 0, 0, LastRowOfUsedArea)
   oCursor = oSheet.createCursorByRange(oRange)
   RangeData = oCursor.getDataArray

   For R = UBound(RangeData) To LBound(RangeData) Step - 1
       If RangeData(R)(0) <> "" then
          LastRowWithData = R
          Exit Function
       End If
   Next
End Function
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Поменять местами два средних столбца,если количество столбцов четное,и первый со средним столбцом,если количество столбцов нечетно Promi C# (си шарп) 5 27.10.2015 20:11
Подсчитать количество букв 'а' в последнем слове строчки. Kirillgr Помощь студентам 20 18.10.2014 10:30
Выделение строчки цветом, максимального значения конкретной группы ячеек sun_nt Microsoft Office Excel 7 26.03.2014 19:47
Есть 2 обьедененых столбца, нужно убрать пробелы из каждой строчки NewStudent07 Microsoft Office Excel 4 20.04.2013 22:06
Как найти число больше 0 из строчки и вставить относительно этого столбца остальные данные в другой лист e_v_b Microsoft Office Excel 4 20.09.2010 06:31