Блог

Я довольно долго борюсь с возможными решениями, но я не смог найти что-то подобное в Интернете, и мне не помешала бы помощь. Пример снимка экрана и пример книги в ссылках, о которых идет речь. Я задавал один и тот же вопрос на другом форуме, но ответов не было… https://www.mrexcel.com/board/threads/find-copy-insert-row-on-condition-with-cell-merge-and-formula-copy.1178634/

У меня есть 3 рабочих листа, ForDelivery , Document1 и Document2 . С листов документов, которые я распечатываю на первой странице или отправляю по электронной почте, я хочу заполнить определенные ячейки на листах документов 1 и 2 ( range"G19:K" ) значениями с ForDelivery листов (значения находятся в диапазоне "B2:F" .

В листах Document1 и Document2 у меня есть шаблон таблицы, столбец «Б» в обеих таблицах содержат названия продуктов, мне нужен макрос, который будет искать эти имена в лист ForDelivery и в случае, если имя находится в столбце "A" а затем скопировать все значения из диапазона "B:F" от строки, где имя было найдено в строке листа, где имя столбца диапазона "G:K" . Я собираюсь выполнить эту работу, XLOOKUP fuction НО проблема возникает, когда в столбце указано более одного названия продукта "A" (число может варьироваться от 2 до 8). Эта функция не справляется, но я надеюсь, что макрос справится. Поэтому для каждого одного и того же имени мне нужно вставить новую строку под исходной строкой, скопировать форумы сверху и вставить значения в диапазон "G:K" . Я создал код, который будет объединять ячейки в столбцах A B , и F , чтобы предотвратить дублирование значений. Таким образом, в принципе, если в столбце листа есть 3 одинаковых имени "A" ForDelivery , вставьте 2 строки (2, потому что уже существует одна строка) в Document 1 or 2 лист, где найдено имя, и вставьте данные из диапазона B:F в диапазон G:K . Заранее спасибо.

Скриншот: https://ibb.co/sFh5dRY Образец рабочей тетради здесь: https://easyupload.io/4f7cq2

Если это полезно, вот код, который я использую для объединения ячеек в столбцах

 Sub macro1()
Dim lngLastRow As String
Dim lastRow As Long
Dim lastcolumn As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
lastRow = ActiveSheet.UsedRange.Row - 1   ActiveSheet.UsedRange.Rows.Count
lastcolumn = ActiveSheet.UsedRange.Column - 1   ActiveSheet.UsedRange.Columns.Count

ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range(Cells(19, 1), Cells(lastRow, 1)), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

With ActiveSheet.Sort
.SetRange Range(Cells(19, 1), Cells(lastRow, lastcolumn))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

For i = lastRow To 19 Step -1

If Cells(i, 1).Value = Cells(i - 1, 1).Value Then
Range(Cells(i, 1), Cells(i - 1, 1)).Select
Selection.Merge
Range(Cells(i, 2), Cells(i - 1, 2)).Select
Selection.Merge
Range(Cells(i, 3), Cells(i - 1, 3)).Select
Selection.Merge
Range(Cells(i, 6), Cells(i - 1, 6)).Select
Selection.Merge

End If

Next
Application.ScreenUpdating = True

End Sub
 

Вы можете попробовать этот код, я добавил комментарии, чтобы вы могли иметь представление о том, что происходит. Кодовое имя дается внутри VBA для любого листа, они хороши, если ваши листы никто не удалит. Если нет, измените их на имена ваших листов, как обычно.

Примечание: Я не могу видеть комментарии в другом цвете в предварительном просмотре. Кроме того, не проверял часть формулы. Извините, если я что-то пропустил.

 Public Sub Populate_Document1()
    
    Dim i As Long, no_item_doc1 As Long, currentrow_doc1 As Long
    Dim rngDelivery As Range
    Dim cCell_Doc1 As Range
    Dim cCell_Delivery As Range
    
    Dim rngDoc1 As Range
    Dim arrDoc1 As Variant
    Dim lastrow_doc1 As Long
    
    ' Find last row of Document1 (Codename set as doc1 in VBA Editor)
    ' doc1 = sheets("Document1")
    ' delivery = sheets("ForDelivery")
    lastrow_doc1 = doc1.Cells(18, 2).End(xlDown).Row
    
    Set rngDoc1 = doc1.Range("B19:B" amp; lastrow_doc1)
    
    ' Assign rngDoc1 values to an array arrDoc1
    ReDim arrDoc1(1 To rngDoc1.Rows.Count, 1 To 1) As String
    arrDoc1 = rngDoc1.Value ' arrays normally start with index 0, but 1 if we assign from a range
    
    ' Set rngDelivery to items list on ForDelivery Sheet
    ' Can be done in one line, but easier to read like this
    Set rngDelivery = delivery.Range("A1").CurrentRegion
    Set rngDelivery = rngDelivery.Offset(1, 0).Resize(rngDelivery.Rows.Count - 1, 1)
    
    currentrow_doc1 = 19 ' will update this if we insert any lines due to duplicates
    
    For i = 19 To lastrow_doc1
        no_item_doc1 = 0 ' reset to 0, number of items found on delivery sheet for the item in question in doc1
        For Each cCell_Delivery In rngDelivery
            If cCell_Delivery.Value = arrDoc1(i - 18, 1) Then
                If no_item_doc1 = 0 Then
                    no_item_doc1 = 1
                    cCell_Delivery.Offset(0, 1).Resize(1, 5).Copy doc1.Range("G" amp; currentrow_doc1)
                Else
                    ' increase currentrow since a duplicate is found
                    currentrow_doc1 = currentrow_doc1   1
                    
                    ' Insert a row
                    doc1.Rows(currentrow_doc1).Insert
                    
                    ' copy the B-F columns from delivery sheet
                    cCell_Delivery.Offset(0, 1).Resize(1, 5).Copy doc1.Range("G" amp; currentrow_doc1)
                    
                    ' copy A-F columns of duplicate item from 1 row above
                    doc1.Range("A" amp; currentrow_doc1 - 1 amp; ":F" amp; currentrow_doc1 - 1).Copy doc1.Range("A" amp; currentrow_doc1 amp; ":F" amp; currentrow_doc1)
                    
                    ' copy the formulas from 1 row above
                    doc1.Range("D" amp; currentrow_doc1 - 1 amp; ":E" amp; currentrow_doc1 - 1).Copy
                    doc1.Range("D" amp; currentrow_doc1 amp; ":E" amp; currentrow_doc1).PasteSpecial Paste:=xlPasteFormulasAndNumberFormats
                    
                    ' set font color to easily distinguish duplicates, can remove later if you want
                    doc1.Range("A" amp; currentrow_doc1 amp; ":F" amp; currentrow_doc1).Font.Color = rgbRed
                End If
            End If
        Next cCell_Delivery
        
        ' increase currentrow by 1 since we are moving on to the next item on doc1
        currentrow_doc1 = currentrow_doc1   1
    Next i
    
    ' clean up set objects, not necessary here but good practice
    Set rngDoc1 = Nothing
    Set rngDelivery = Nothing
    
End Sub