Question

首先，你好，

我正在处理一个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

我希望你明白我的意思。如果您有任何想法如何修复我的代码我会非常高兴（我花了至少一个星期来使它工作）

进一步可视化问题

sheet1 sheet2

非常感谢阅读并试图提供帮助。

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

Answer 1

要使第二个Worksheet("Sheet2")与Worksheet("Sheet1")同步，您可以将Sub代码模块中显示的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）

希望这可能会有所帮助。

Answer 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

找到正确复制粘贴位置的VBA宏

2 个答案: