Macro for copying data between sheets - Help needed.

[Mark Campbell]

I am a beginner to VBA and am looking for some help writing a Macro.

I have approx 900 rows of data in sheet1 of a workbook. Row A contains the
column headings for the data which is contained in columns A - I . Col A
contains a unique reference code for each row of data. Col B a descrition and
the other columns contain dates, times and percentages.

I update the data in sheet 1 weekly by first deleting the old data and
pasting in the updated data which is sourced from a project management
software programme.

I am seeking a macro which will copy the data from sheet 1 into sheet 2 when
I activate a control button. The Macro needs to perform the following:

a) For each row of data in sheet 1 - look up sheet 2 to see if the record
already exists (using the col A unique reference code)

b) If the record does not exist - paste the new record into the next free
row in sheet 2.

c) If the record does exist - update columns B - I in sheet 2 with the new
data from sheet1. (Where the new data contains empty cells - I do not wish to
over write existing data in sheet 2)

The following conditions are also present:
a) Sheet 1 contains a number of blank rows - i can remove these if necessary
to make the macro work.
b) Sheet 2 contains some conditional formating which I dont want to lose.
c) Some of the columns in Sheet 2 into which data is to be copied may be
hidden.
d) Autofilters may also be applied to sheet 2 prior to running the macro.

Apologies for the lenght of this post - I hope I have explained by
requirements.
I have looked at Ron's site on this topic but am still a unsure as to the
code needed.
Thanks in advance for any help offered.
Regards
Mark

 

[Mike]

You could put a name change button on each sheet that calls this macro

Sub sheetnamechange()

ActiveWorkbook.Unprotect
Message = "Enter new sheet name"
newname = InputBox(Message)
If newname = "" Then ActiveWorkbook.Protect: End
ActiveSheet.Name = newname
ActiveWorkbook.Protect


End Sub

Mike

 

[Mike]

OOPs sorry posted to wrong answer

You could put a name change button on each sheet that calls this macro

Sub sheetnamechange()

ActiveWorkbook.Unprotect
Message = "Enter new sheet name"
newname = InputBox(Message)
If newname = "" Then ActiveWorkbook.Protect: End
ActiveSheet.Name = newname
ActiveWorkbook.Protect


End Sub

Mike

 

[Mark Campbell]

Mike,

This isnt really what i want to do as - I have other data on sheet 2 which I
dont want to be affected - and also other parts of my workbook rely on data
from these 2 sheets so changing the names would only confuse matters.

 

[Mike]

Mark,

apologies I poster this answer to the wrong question. too much NYE alcohol I
think.

Mike

 

[Otto Moehrbach]

The following macro will do what you want. Note that your first sheet must
be the active sheet and, as written, your second sheet must be name "Two".
This will work even if some of the columns in sheet "Two" are hidden. I
don't know about the filter, though. Give it a try and see. Watch out for
line wrapping. HTH Otto
Sub UpdateTwo()
Dim RngAOne As Range
Dim RngATwo As Range
Dim i As Range
Set RngAOne = Range("A2", Range("A" & Rows.Count).End(xlUp))
With Sheets("Two")
Set RngATwo = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
For Each i In RngAOne
If RngATwo.Find(What:=i.Value, LookAt:=xlWhole) Is Nothing
Then
i.Resize(, 9).Copy .Range("A" &
Rows.Count).End(xlUp).Offset(1)
Else
i.Offset(, 1).Resize(, 8).Copy
RngATwo.Find(What:=i.Value, LookAt:=xlWhole).Offset(, 1)
End If
Next i
End With
End Sub

 

[Mark Campbell]

Thanks for your code which does exactly what i need.

One problem i have encountered however that if a cell in a row of sheet 1 is
blank - it copies the blank cell into sheet 2 overwriting any data which I
have entered in sheet 2.

Is it possible to insert an additional line of code so as blank cells are
not copied.
Best regards
Mark

 

[Otto Moehrbach]

Mark
Try this macro. I placed all the action inside of an IF statement that
checks that the cell is not blank.
Sub UpdateTwo()
Dim RngAOne As Range
Dim RngATwo As Range
Dim i As Range
Set RngAOne = Range("A2", Range("A" & Rows.Count).End(xlUp))
With Sheets("Two")
Set RngATwo = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
For Each i In RngAOne
If Not IsEmpty(i.Value) Then
If RngATwo.Find(What:=i.Value, LookAt:=xlWhole) Is
Nothing Then
i.Resize(, 9).Copy .Range("A" &
Rows.Count).End(xlUp).Offset(1)
Else
i.Offset(, 1).Resize(, 8).Copy
RngATwo.Find(What:=i.Value, LookAt:=xlWhole).Offset(, 1)
End If
End If
Next i
End With
End Sub

 

[Otto Moehrbach]

The blank cell I was talking about is in Column A of the first sheet. Is
that what you meant? Otto

 

[Mark Campbell]

No, I dont want to copy over any blank cells contained in any of columns A-I
of the 1st sheet. Mark

 

[Otto Moehrbach]

Mark
Let me see if I have this straight. You have data in sheet1 with an ID
number in Column A.
In sheet 2 you have the same ID numbers in Column A.
You want to update the data in Sheet2 with that data in Sheet1.
If an ID number in sheet1 is not found in sheet 2, you want the whole
row copied from sheet1 to the first empty row of sheet 2.
If the number is found, you want those cells in sheet2 updated with the
data in sheet1, BUT only if the cell in sheet1 is occupied. That way, a
blank cell in sheet1 will not displace an occupied cell in sheet2. Is that
right? Otto

 

[Otto Moehrbach]

Mark
Try this macro.
Sub UpdateTwo()
Dim RngAOne As Range
Dim RngATwo As Range
Dim RngOneRow As Range
Dim Dest As Range
Dim i As Range
Dim j As Range
Set RngAOne = Range("A2", Range("A" & Rows.Count).End(xlUp))
With Sheets("Two")
Set RngATwo = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
For Each i In RngAOne
If RngATwo.Find(What:=i.Value, LookAt:=xlWhole) Is Nothing
Then
i.Resize(, 9).Copy .Range("A" &
Rows.Count).End(xlUp).Offset(1)
Else
Set Dest = RngATwo.Find(What:=i.Value,
LookAt:=xlWhole)
Set RngOneRow = Range(Cells(i.Row, 2), Cells(i.Row,
9))
For Each j In RngOneRow
If Not IsEmpty(j.Value) Then _
j.Copy .Cells(Dest.Row, j.Column)
Next j
End If
Next i
End With
End Sub

 

[Otto Moehrbach]

Mark
Glad it works for you. Thanks for the feedback. Otto