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

Question

First of all hello guys,

I´m currently working on a VBA script as you may see from the title. The thing is I only know some basic java and the things I looked up here and there to make my code running.

Now the thing is I want to have two sheets that synchronise.

To be more clear, if you write something in sheet1 and activate the macro it gets copied into the correct fields in sheet2.

My current code looks like this and i guess its the easiest way to get what I want to do:

    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

I hope you get what I mean. If you have any ideas how to fix my code I would be very happy (I spent at least a week to make it work)

To further visualise the problem

sheet1 sheet2

Thanks a lot for reading and trying to help.

If you need more information don't hesitate to ask I will provide as quick as possible :)

Answer 1

To keep the second Worksheet("Sheet2") synchronized with Worksheet("Sheet1") , you may place the VBA Sub shown below in the Worksheet("Sheet1") code module:

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

Thus, anything changed in the first Worksheet will be automatically reflected in the second one.

You can further modify this Sub pertinent to your particular requirements, for example setting the Range that should be reflected by using Intersect (re: https://msdn.microsoft.com/en-us/library/office/ff839775.aspx )

Hope this may help.

Answer 2

edited after OP's request (see lines with '<=== edited comment)

maybe you need something like follows

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