Excel VBA - подпрограмма, которая находит на одном листе и вставляет в другой, перемещая ячейки назначения вниз

Question

Очень признателен за любую помощь в этом!

У меня есть 3 столбца на 11 листах Excel, которые необходимо скопировать в уникальный лист назначения.

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

Что у меня есть:

Sub PopulateFileTOupload ()

'переменные

Dim strFileToSave As String

Dim wbSource As Workbook
Dim wsSource As Worksheet

Dim wbTarget As Workbook
Dim wsTarget As Worksheet

Dim rngToCopy1 As Range, rngToCopy2 As Range, rngToCopy3 As Range
Dim dt As String, wbNam As String, wbDir As String

Dim FoundCell As Range, FirstAddr As String, fnd As String, i As Long

' ====================== SOURCE ================

Set wbSource = Workbooks.Open("C:\Users\MLOURENC\Documents\0041_PRORATA_ANNUAL_CONTRACTS_UPLOAD.xls")
Set wsSource = wbSource.Worksheets("Month1")

' ================ COPY & PASTE ================

' source range1

Set rngToCopy1 = wsSource.Range("E1", wsSource.Range("E1").End(xlDown))
Set rngToCopy2 = wsSource.Range("N1", wsSource.Range("N1").End(xlDown))
Set rngToCopy3 = wsSource.Range("P1", wsSource.Range("P1").End(xlDown))

Set wbTarget = Workbooks.Open("C:\Users\MLOURENC\Desktop\UP_FRONT S&D\0041_PT\2.Anual-Template\0041_PRORATA ANNUAL CONTRACTS_UPLOAD_TEMPLATE.xls")


' Paste range1


' DON 't know....



' ================ SAVE ================
wbNam = "0041_PRORATA_ANNUAL_CONTRACTS_UPLOAD_READY_"
dt = Format(CStr(Now), "dd_mm_yyyy_hh_mm")
wbTarget.SaveAs Filename:=wbNam & dt
' ================ CLOSE ================'
Application.DisplayAlerts = False
wbTarget.Close
Application.DisplayAlerts = True

End Sub

Answer 1

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

Позволяет сказать, что данные вВаша целевая рабочая книга отформатирована примерно так, все на одном листе, если я правильно понимаю ваш вопрос:

January
    Data
    Data
    Data
    Data
February
    Data
    Data
    Data
    Data
ETC ETC
    Data
    Data
    Data
    Data

Основные шаги будут:

Определитьномер строки, в которую вы хотите добавить данные

Dim monthRow As Long
monthRow = wbTarget.Sheets(1).Range("A:A").Find("January:", LookIn:=xlValues).Row

Проверьте количество строк в исходных данных

Dim janRows As Long
janRows = rngToCopy1.rows.count

Вставьте столько свободных строк в целевую книгу

wbTarget.Sheets(1).Rows(monthRow + 1 & ":" & monthRow + janRows).EntireRow.Insert

Передача данных по

wbTarget.Sheets(1).Range("B" & monthRow + 1 & ":B" & monthRow + janRows) = rngToCopy1

Существуют различные способы сделать это (более чем один способ снять шкуру с кошки), но я думаю, что это будет проще всего.

Я надеюсь, что этопомогает, если нет, я буду рад помочь в дальнейшем.