VBA problem

[fabiogiallo]

Good afternoon,

i have the code in the attached excel file to copy data from sheet2 to sheet1 when the record numbers are matching: it works only if i run the macro from sheet1, but i would make it run from sheet2 (placing the button), any help?

Another question: it would be possible to modify the code, adding a message error when, copying from sheet2 to sheet1, the destination cells in sheet1 are not empty?

Thank you.

[Paul_Hossler]

I'd do something like this




Option Explicit


Sub find_and_copy()
Dim rFrom As Range, rTo As Range, r As Range
Dim wsFrom As Worksheet, wsTo As Worksheet
Dim n As Long


Set wsFrom = Worksheets("From")
Set wsTo = Worksheets("To")


Set rFrom = wsFrom.Cells(1, 1).CurrentRegion
Set rFrom = rFrom.Cells(2, 1).Resize(rFrom.Rows.Count - 1, rFrom.Columns.Count)


Set rTo = wsTo.Cells(1, 1).CurrentRegion


For Each r In rFrom.Columns(1).Cells

n = 0
On Error Resume Next
n = Application.WorksheetFunction.Match(r.Value, rTo.Columns(1), 0)
On Error GoTo 0

If n > 0 Then
If Application.WorksheetFunction.CountA(rTo.Rows(n)) > 1 Then
MsgBox r.Value & " in row " & n & " already has data"

Else
r.EntireRow.Copy wsTo.Cells(n, 1)
End If
End If
Next

Application.ScreenUpdating = True
MsgBox "Finito"

End Sub

[fabiogiallo]

Hi Paul,

thanks for this, but you have inverted the sheets, i would need data from sheet "to" to sheet "from" and i am not sure how to change it.

[p45cal]

The one bit that needs changing is an unqualified reference.
Change:
For Each ce In Worksheets("Sheet1").Range("A2:A" & [COUNTA(A:A)])
to:
For Each ce In Worksheets("Sheet1").Range("A2:A" & [COUNTA(Sheet1!A:A)])

[p45cal]

Oops, forgot the second part; you can test if the destination cells are empty with:
If rng1.Cells.Count = Application.CountBlank(rng1) Then

In full:
Sub find_and_copy()
Dim ce As Range
Dim f As Range
Dim r As Long
Dim rng1 As Range, rng2 As Range

Application.ScreenUpdating = False

For Each ce In Worksheets("Sheet1").Range("A2:A" & [COUNTA(Sheet1!A:A)])
Set f = Worksheets("Sheet2").Range("A:A").Find(ce, lookat:=xlWhole)
If Not (f Is Nothing) Then
r = WorksheetFunction.CountA(f.EntireRow)
Set rng1 = Worksheets("sheet1").Range(Worksheets("sheet1").Cells(ce.Row, 5), Worksheets("sheet1").Cells(ce.Row, 3 + r))
If rng1.Cells.Count = Application.CountBlank(rng1) Then
Set rng2 = Worksheets("sheet2").Range(Worksheets("sheet2").Cells(f.Row, 2), Worksheets("sheet2").Cells(f.Row, r))
rng1.Value = rng2.Value
Else
Application.Goto rng1 'to show the user the destination cells
Application.ScreenUpdating = True
MsgBox "destination cells are not empty"
Application.ScreenUpdating = False
End If
End If
Next
Application.ScreenUpdating = True
MsgBox "Finito"
End Sub

[fabiogiallo]

It works very good, thank you!

Thank you ALL.