VBA宏找到將粘貼復制到的正確位置

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")保持同步，您可以將下面顯示的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 （請參閱： https : //msdn.microsoft.com/zh-cn/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