[storm_Zcooler]

ок. Давайте по порядку.

В исходном файле есть диапазон с9:с17(это коробки), этот диапазон не постоянен может быть больше коробок может быть меньше, этот диапазон определяется объединением ячеек J9(Pallet #1 это площадка на которой размещаются эти коробки). Как можно сделать чтобы копировались данные (коробки которые стоят на площадке Pallet #1) только которые в диапазоне объединения ячеек J9.

наверное опять не понятно сказал

[Iska]

storm_Zcooler, использование запятых в предложениях облегчит понимание собеседнику.

[storm_Zcooler]

Спасибо за помощь закрываем тему там на самом деле всё гораздо сложней чем казалось изначально...

[storm_Zcooler]

Как сделать в примере, чтобы числа во втором столбце, через запятую, опустились ниже на ячейку, и остальные данные, которые в этой же строке скопировались так же вниз. На примере думаю видно.

[Iska]

storm_Zcooler, примерно так:

читать дальше »

Код:

Option Explicit

Sub SomeSample()
    Dim objRange As Range
    
    Dim i As Long
    Dim j As Long
    
    Dim arrValues() As String
    
    
    With Selection.Cells
        For i = .Count To 1 Step -1
            With .Item(i)
                arrValues = Split(.Value, ",")
                
                For j = UBound(arrValues) To LBound(arrValues) Step -1
                    .EntireRow.Offset(1).Insert
                    
                    .Offset(1, 0).Value = arrValues(j)
                    .Offset(1, -1).Value = .Offset(0, -1).Value
                    .Offset(1, 1).Value = .Offset(0, 1).Value
                    .Offset(1, 2).Value = .Offset(0, 2).Value
                Next
                
                .EntireRow.Delete
            End With
        Next
    End With
End Sub

Перед исполнением макроса необходимо выделить потребный диапазон со значениями. В Вашем примере это «B2:B4».

А вообще, какое отношение теперешний вопрос имеет к озвученной теме — «Запрос диалогового окна выбора excel файла»?

[storm_Zcooler]

Приветствую, спасибо за советы но вот задачка немного изменилась, надо чтобы значения после запятой опускались вниз и всё что слева тоже копировались, а справа только в 1 раз оставались. Прикладываю файл там думаю понятней будет.

P.S. у тебя есть яндекс кошелек? Отблагодарю.

[Iska]

а справа только в 1 раз оставались. »

Удалите или закомментируйте ненужные присвоения:

Код:

.Offset(XXX, XXX).Value = …

2003: Offset Property [Excel 2003 VBA Language Reference]
2007: Offset Property
2010: Offset Property

Впрочем, никакой разницы по версиям нет. Ну, да ладно.

P.S. у тебя есть яндекс кошелек? »

Нет. Обычного, впрочем, тоже нет.

Отблагодарю. »

Попробуйте обратиться к Администрации, может им сгодится.

[storm_Zcooler]

а справа только в 1 раз оставались. » Удалите или закомментируйте ненужные присвоения: Код: .Offset(XXX, XXX).Value = … »

Если её удаляю, то значения не будут копироваться вообще, а мне надо только, чтобы в первая строка копировалась полностью, а ниже добавлялись строки со значениями, которые отделяются запятой и всё, что справа было от них, а слева было пусто.

Обновил пример во вложении, может так наглядней будет.

[Iska]

storm_Zcooler, не доглядел с первого раза, не понял до конца Вашей потребности. Приношу Вам свои извинения.

Значит, будет достаточно проверять счётчик и на последнем проходе цикла разбора дублировать и ячейки справа, наподобие:

читать дальше »

Код:

Option Explicit

Sub SomeSample()
    Dim objRange As Range
    
    Dim i As Long
    Dim j As Long
    
    Dim arrValues() As String
    
    
    With Selection.Cells
        For i = .Count To 1 Step -1
            With .Item(i)
                arrValues = Split(.Value, ",")
                
                For j = UBound(arrValues) To LBound(arrValues) Step -1
                    .EntireRow.Offset(1).Insert
                    
                    .Offset(1, 0).Value = arrValues(j)
                    
                    .Offset(1, -4).Value = .Offset(0, -4).Value
                    .Offset(1, -3).Value = .Offset(0, -3).Value
                    .Offset(1, -2).Value = .Offset(0, -2).Value
                    .Offset(1, -1).Value = .Offset(0, -1).Value
                    
                    If j = LBound(arrValues) Then
                        .Offset(1, 1).Value = .Offset(0, 1).Value
                        .Offset(1, 2).Value = .Offset(0, 2).Value
                        .Offset(1, 3).Value = .Offset(0, 3).Value
                        .Offset(1, 4).Value = .Offset(0, 4).Value
                    End If
                Next
                
                .EntireRow.Delete
            End With
        Next
    End With
End Sub

Или вовсе на последнем проходе новую строку не добавлять, саму оригинальную строку не удалять, а просто менять значение разбираемой ячейки на последнее значение разбора:

читать дальше »

Код:

Option Explicit

Sub SomeSample()
    Dim objRange As Range
    
    Dim i As Long
    Dim j As Long
    
    Dim arrValues() As String
    
    
    With Selection.Cells
        For i = .Count To 1 Step -1
            With .Item(i)
                arrValues = Split(.Value, ",")
                
                For j = UBound(arrValues) To LBound(arrValues) Step -1
                    If j = LBound(arrValues) Then
                        .Value = arrValues(j)
                    Else
                        .EntireRow.Offset(1).Insert
                        
                        .Offset(1, 0).Value = arrValues(j)
                        
                        .Offset(1, -4).Value = .Offset(0, -4).Value
                        .Offset(1, -3).Value = .Offset(0, -3).Value
                        .Offset(1, -2).Value = .Offset(0, -2).Value
                        .Offset(1, -1).Value = .Offset(0, -1).Value
                    End If
                Next
            End With
        Next
    End With
End Sub

Думаю, так даже лучше будет.