Макрос VBA, который находит правильное место для копирования пасты в

Прежде всего, привет, ребята,

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

Теперь я хочу, чтобы два листа синхронизировались.

Чтобы быть более понятным, если вы пишете что-то в sheet1 и активируете макрос, он копируется в правильные поля в sheet2.

Мой текущий код выглядит так, и я думаю, что это самый простой способ получить то, что я хочу сделать:

Sub magic() Dim sh1 As Worksheet Dim sh2 As Worksheet Set sh1 = ActiveWorkbook.Sheets("Postenkosten") Set sh2 = ActiveWorkbook.Sheets("Monatskosten") Dim Pa As Integer Dim Pb As Integer Dim Ma As Integer Dim Mb As Integer // go through the designated columns and rows For Pa = 4 To 34 Step 3 For Pb = 6 To 10 Step 1 // check if they are empty If sh1.Cells(Pb, Pa).Value <> "" Then //if not got to sheet2 and look the designated cells there For Ma = 1 To 30 Step 3 For Mb = 1 To 12 Step 1 //here comes the critical part - if my cell from sheet 1 is the same as the headline (cell) in sheet 2 then... //if not look for the next headline and compare If sh1.Cells(Pb, Pa) = sh2.Cells(Ma, 2) Then //make sure you have a empty row so you don't override things and copy the cells adjacent to sheet 2 If sh2.Cells(Mb, Ma) = "" Then Else sh1.Cells(4, Pa).Value.Copy sh2.Cells(Mb, Ma) sh1.Cells(Pb + 1, Pa).Value.Copy sh2.Cells(Mb + 1, Ma) sh1.Cells(Pb + 2, Pa).Value.Copy sh2.Cells(Mb + 2, Ma) End If End If Next Mb Next Ma End If Next Pb Next Pa End Sub //go and do this for the next cell in sheet 1 

Надеюсь, вы поняли, что я имею в виду. Если у вас есть идеи по исправлению кода, я был бы очень рад (я потратил хотя бы неделю, чтобы заставить его работать)

Чтобы дополнительно визуализировать проблему

лист1 лист2

Большое спасибо за чтение и помощь.

Если вам нужна дополнительная информация, не стесняйтесь спросить, я предоставит вам как можно быстрее 🙂

отредактированный после запроса OP (см. строки с '<=== edited комментарий)

возможно, вам нужно что-то вроде следующего

 Sub magic() Dim sh1 As Worksheet Dim sh2 As Worksheet Dim postenDates As Range, monatDates As Range, cell As Range, fndRng As Range Set sh1 = ActiveWorkbook.Worksheets("Postenkosten") Set sh2 = ActiveWorkbook.Worksheets("Monatskosten") Set postenDates = SetDatesRange(sh1.Range("D6:D24"), 1, 10, 1, 3) '<== set base range and its "multiplying" factors as per your needs Set monatDates = SetDatesRange(sh2.Range("A2:AJ2"), 3, 1, 18, 1) '<== set base range and its "multiplying" factors as per your needs For Each cell In postenDates Set fndRng = FindDate(cell, monatDates) If Not fndRng Is Nothing Then If IsEmpty(fndRng.Offset(13)) Then '<=== edited With fndRng.End(xlDown) '<=== edited sh1.Cells(4, cell.Column).Copy '<=== edited .Offset(1).PasteSpecial xlPasteValues '<=== edited cell.Offset(, 1).Resize(, 2).Copy '<=== edited .Offset(1, 1).PasteSpecial xlPasteValues '<=== edited End With '<=== edited End If End If Next cell End Sub Function FindDate(rngToFind As Range, rngToScan As Range) As Range Dim cell As Range For Each cell In rngToScan If cell = rngToFind Then Set FindDate = cell Exit For End If Next cell End Function Function SetDatesRange(iniRng As Range, nRowsSteps As Long, nColsSteps As Long, rowStep As Long, colStep As Long) As Range Dim unionRng As Range Dim i As Long, j As Long Set unionRng = iniRng With iniRng For i = 1 To nRowsSteps For j = 1 To nColsSteps Set unionRng = Union(unionRng, .Offset((i - 1) * rowStep, (j - 1) * colStep)) Next j Next i End With Set SetDatesRange = unionRng.SpecialCells(xlCellTypeConstants) End Function 

Чтобы сохранить второй Worksheet("Sheet2") синхронизированный с Worksheet("Sheet2") , вы можете поместить указанный ниже код VBA в модуль кода Worksheet("Sheet1") :

 Private Sub Worksheet_Change(ByVal Target As Excel.Range) r = Target.Row c = Target.Column Worksheets("Sheet2").Cells(Target.Row, Target.Column).Value = Target End Sub 

Таким образом, все, что изменилось в первом рабочем листе, будет автоматически отражено во втором.

Вы можете дополнительно модифицировать этот Sub, соответствующий вашим конкретным требованиям, например, установить Range который должен быть отражен с помощью Intersect (re: https://msdn.microsoft.com/en-us/library/office/ff839775.aspx )

Надеюсь, это поможет.

Давайте будем гением компьютера.