VBAmacrosfind正确的地方复制粘贴到

首先你好，

我正在编写一个VBA脚本，你可以从标题中看到。 事情是我只知道一些基本的Java和我在这里和那里查找的东西，使我的代码运行。

现在的事情是我想有两张同步。

更清楚的是，如果在sheet1中写入某些内容并激活该macros，它将被复制到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 

我希望你明白我的意思。 如果你有任何想法如何解决我的代码，我会很高兴（我花了至less一个星期，使其工作）

进一步可视化问题

sheet1 sheet2

非常感谢您的阅读和帮助。

如果您需要更多的信息，请不要犹豫，我会尽快提供:)

Answer 1

在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 

Answer 2

要使第二个Worksheet("Sheet2")与Worksheet("Sheet1") Worksheet("Sheet2")同步，可以将下面显示的VBA Sub放置在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与你的特定需求相关，例如设置应该通过使用Intersect反映的Range （re： https : //msdn.microsoft.com/en-us/library/office/ff839775.aspx ）

希望这可能有帮助。