Copy from sheet1 and sheet2 and append to sheet3 in different format

  • Thread starter Thread starter Ivan Hung
  • Start date Start date
I

Ivan Hung

Hi,
I am learning VBA Excel and have attempted this, but can't seem to get it to
work together.

I have sheet1, sheet2 and sheet3 in the same workbook. I would like to
append data (value only) from sheet1 and sheet2 and append to the last blank
row on sheet3. I have the following information on the sheet1 and sheet2,
what I would like to have is sheet3. Can someone help me out?

Sheet1
A B C D E F
G H I J K L M
N
Name PayCAT 1-Apr-09 1-May-09 1-Jun-09 1-Jul-09 1-Aug-09 1-Sep-09 1-Oct-09
1-Nov-09 1-Dec-09 1-Jan-10 1-Feb-10 1-Mar-10
Peter Base 10,000 10,000 10,000 10,000 10,000 10,000
10,000 10,000 10,000 11,000 11,000 11,000
John Base 12,000 12,000 12,000 12,000 12,000 12,000
12,000 12,000 12,000 13,000 13,000 13,000

Sheet2
A B C D E F
G H I J K L M
N
Name PayCAT 1-Apr-09 1-May-09 1-Jun-09 1-Jul-09 1-Aug-09 1-Sep-09 1-Oct-09
1-Nov-09 1-Dec-09 1-Jan-10 1-Feb-10 1-Mar-10
Peter Bonus 0 18,000 0 0 0
0 0 0 10,000 0 0 0
John Bonus 0 20,000 0 0 0
0 0 0 12,000 0 0 0

Sheet3
A B C D
Name PayCAT Month Amount
Peter Base Apr-09 10,000
John Base Apr-09 12,000
Peter Base May-09 10,000
John Base May-09 12,000
Peter Bonus May-09 18,000
John Bonus May-09 20,000
Peter Base Jun-09 10,000
John Base Jun-09 12,000
Peter Base Jul-09 10,000
John Base Jul-09 12,000
Peter Base Aug-09 10,000
John Base Aug-09 12,000
Peter Base Sep-09 10,000
John Base Sep-09 12,000
Peter Base Oct-09 10,000
John Base Oct-09 12,000
Peter Base Nov-09 10,000
John Base Nov-09 12,000
Peter Base Dec-09 10,000
Peter Bonus Dec-09 10,000
John Base Dec-09 12,000
John Bonus Dec-09 12,000
Peter Base Jan-10 11,000
John Base Jan-10 13,000
Peter Base Feb-10 11,000
John Base Feb-10 13,000
Peter Base Mar-10 11,000
John Base Mar-10 13,000

I would like the user to be prompted with the dialog box for current month
in the format "dd-mmm-yy", if the user input is invalid (outside the date
range on sheet1), then prompt user again, if user input is blank, then clear
data on sheet3 and copy 12 months data from sheet1/sheet2 and append to the
last blank row on sheet3, otherwise only copy the current month data from
sheet1/sheet2 and append to the last blank row on sheet3.

In addition, if the amount on sheet1 or sheet2 is zero, no record for the
month will be appended to sheet3.

Any response would be greatly appreciated!

Many thanks,
Ivan
 
Hi, joel

Thank you for your prompt help.

I have tried your codes and, when prompted, I input blank and
click OK. The codes are great and meets most of my expectation
except column "month".

Name PayCAT Month Amount
Peter Base 10000 10,000
Peter Base 10000 10,000
Peter Base 10000 10,000
Peter Base 10000 10,000
Peter Base 10000 10,000
Peter Base 10000 10,000
Peter Base 10000 10,000
Peter Base 10000 10,000
Peter Base 10000 10,000
Peter Base 10000 11,000
Peter Base 10000 11,000
Peter Base 10000 11,000
John Base 12000 12,000
John Base 12000 12,000
John Base 12000 12,000
John Base 12000 12,000
John Base 12000 12,000
John Base 12000 12,000
John Base 12000 12,000
John Base 12000 12,000
John Base 12000 12,000
John Base 12000 13,000
John Base 12000 13,000
John Base 12000 13,000
Peter Bonus 0 18,000
Peter Bonus 0 10,000
John Bonus 0 20,000
John Bonus 0 12,000

Besides, when prompt for "Enter Date or nothing to copy all dates",
I input 4/1/2009 and click OK, then an error message pops up
"Date error - can't find date : 1-Apr-2009" and then no data are
appended to sheet3.

FYI, I use Office 2003 and Windows XP with English (US) formats
in the Region and Language.

Can you please let me know how to change the code for the above?

Many thanks to your advice.

Ivan

joel said:
I think I met all requirements



Sub GetMonthlyData()

DataSheets = Array("Sheet1", "Sheet2")

PromptStr = "Enter Date or nothing to copy all dates"
Do
MyDate = InputBox(Title:="get Date", _
Prompt:=PromptStr)
If MyDate = "" Then
CopyAll = True
Exit Do
Else
If IsDate(MyDate) Then
MyDate = DateValue(MyDate)

For Each Sht In DataSheets
With Sheets(Sht)
FirstDate = .Range("C1")
LastDate = .Range("N1")
If MyDate >= FirstDate And _
MyDate <= LastDate Then
CopyAll = False
SourceSht = Sht
Exit Do
End If
End With
Next Sht
End If
End If

PromptStr = "Invalid Date" & vbCrLf & _
"Enter Date or nothing to copy all dates"

Loop While 1 'loop forever

With Sheets("Sheet3")
'format column C for correct month format
Columns("C").NumberFormat = "mmm-yy"

Columns("D").NumberFormat = "0,000"

If CopyAll = True Then
'erase all data
LastRowSht3 = .Range("A" & Rows.Count).End(xlUp).Row
If LastRowSht3 <> 1 Then
Rows("2:" & LastRowSht3).Delete
End If
NewRow = 2
Else
LastRowSht3 = .Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1
End If
End With

If CopyAll = True Then
For Each Sht In DataSheets
With Sheets(Sht)
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For RowCount = 2 To LastRow
Name = .Range("A" & RowCount)
PayCAT = .Range("B" & RowCount)
MyDate = .Range("C" & RowCount)

For ColCount = 3 To 14
Amount = .Cells(RowCount, ColCount)
If Amount <> 0 Then

With Sheets("Sheet3")
Range("A" & NewRow) = Name
Range("B" & NewRow) = PayCAT
Range("C" & NewRow) = MyDate
Range("D" & NewRow) = Amount
NewRow = NewRow + 1
End With
End If
Next ColCount
Next RowCount
End With
Next Sht

Else
With Sheets(Sht)
'get column of date
StrDate = Format(MyDate, "d-mmm-yy")
Set c = .Rows(1).Find(what:=StrDate, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
MsgBox ("Date Error - Can't find date : " & StrDate)
Else

LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For RowCount = 2 To LastRow
Amount = .Cells(RowCount, c.Column)
If Amount <> 0 Then

Name = .Range("A" & RowCount)
PayCAT = .Range("B" & RowCount)
MyDate = .Range("C" & RowCount)

With Sheets("Sheet3")
Range("A" & NewRow) = Name
Range("B" & NewRow) = PayCAT
Range("C" & NewRow) = MyDate
Range("D" & NewRow) = Amount
NewRow = NewRow + 1
End With
End If
Next RowCount
End If
End With
End If

End Sub


--
joel
------------------------------------------------------------------------
joel's Profile: 229
View this thread:
http://www.thecodecage.com/forumz/showthread.php?t=165248

Microsoft Office Help
Click to expand...
 
Oh great, it works perfectly!!! Thank you very much for your prompt
advice!!!
I really appreciate your code and I will use this for my VBA learning.

Ensuring the data only be appended to sheet3, I add one more line
Worksheets("Sheet3").Select
before your code
With Sheets("Sheet3")
'format column C for correct month format
Click to expand...

FYI, the 4/1/09 problem is due to my own mistake. In both sheet1
and sheet2, after formatting the cell from showing "Apr-09" to
"1-Apr-09", the code works fine and meets all my requirements.

Many Thanks!!!
Ivan

I must say big "thank you" to you for your help. It

joel said:
I fixed the problem that the code wasn't getting data from both sheets
and the Date problem wrong in sheet 3. I also fixed some other minor
problems
you didn't report.

I can't duplicate the 4/1/09 problem getting an error that it can't
find the 1-Apr-09. You either have a blank in the cell or you have
single quote in thecell which makes it s string. To solve this problem
I change in the Find method from xlwhole to xlPart.

Sub GetMonthlyData()

DataSheets = Array("Sheet1", "Sheet2")

PromptStr = "Enter Date or nothing to copy all dates"
Do
MyDate = InputBox(Title:="get Date", _
Prompt:=PromptStr)
If MyDate = "" Then
CopyAll = True
Exit Do
Else
If IsDate(MyDate) Then
MyDate = DateValue(MyDate)

For Each Sht In DataSheets
With Sheets(Sht)
FirstDate = .Range("C1")
LastDate = .Range("N1")
If MyDate >= FirstDate And _
MyDate <= LastDate Then
CopyAll = False

Exit Do
End If
End With
Next Sht
End If
End If

PromptStr = "Invalid Date" & vbCrLf & _
"Enter Date or nothing to copy all dates"

Loop While 1 'loop forever

With Sheets("Sheet3")
'format column C for correct month format
Columns("C").NumberFormat = "mmm-yy"

Columns("D").NumberFormat = "0,000"

If CopyAll = True Then
'erase all data
LastRowSht3 = .Range("A" & Rows.Count).End(xlUp).Row
If LastRowSht3 <> 1 Then
Rows("2:" & LastRowSht3).Delete
End If
End If

LastRowSht3 = .Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRowSht3 + 1

End With

If CopyAll = True Then
For Each Sht In DataSheets
With Sheets(Sht)
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For RowCount = 2 To LastRow
Name = .Range("A" & RowCount)
PayCAT = .Range("B" & RowCount)

For ColCount = 3 To 14
Amount = .Cells(RowCount, ColCount)
If Amount <> 0 Then
MyDate = .Cells(1, ColCount)
With Sheets("Sheet3")
Range("A" & NewRow) = Name
Range("B" & NewRow) = PayCAT
Range("C" & NewRow) = MyDate
Range("D" & NewRow) = Amount
NewRow = NewRow + 1
End With
End If
Next ColCount
Next RowCount
End With
Next Sht

Else
For Each Sht In DataSheets

With Sheets(Sht)
'get column of date
StrDate = Format(MyDate, "d-mmm-yy")
Set c = .Rows(1).Find(what:=StrDate, _
LookIn:=xlValues, lookat:=xlpart)
If c Is Nothing Then
MsgBox ("Date Error - Can't find date : " & StrDate)
Else

LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For RowCount = 2 To LastRow
Amount = .Cells(RowCount, c.Column)
If Amount <> 0 Then

Name = .Range("A" & RowCount)
PayCAT = .Range("B" & RowCount)
MyDate = .Cells(1, c.Column)

With Sheets("Sheet3")
Range("A" & NewRow) = Name
Range("B" & NewRow) = PayCAT
Range("C" & NewRow) = MyDate
Range("D" & NewRow) = Amount
NewRow = NewRow + 1
End With
End If
Next RowCount
End If
End With
Next Sht
End If

End Sub

--
joel
------------------------------------------------------------------------
joel's Profile: 229
View this thread:
http://www.thecodecage.com/forumz/showthread.php?t=165248

Microsoft Office Help
Click to expand...
 
Thank you for your detailed explanation. I really want to develop
better programming practices to produce efficient code, especially
when the data is getting bigger and bigger.

I follow your advice and remove the select code. When the sheet3
is the active sheet, there is no problem. However, if any other sheet
is the active sheet, then the result will overwrite the source data.

I am not sure if I miss anything?

Many thanks!!!
Ivan Hung
 
joel,

Thanks again.
I have tried many times to execute the code in sheet1 or sheet2 in vain,
even though I add dot preceding to .Range("A" & NewRow).........

Take sheet2 for example, after executing, the code, source data except
the heading are cleared and appended to the same sheet2 starting from
row 30.

I can't figure out where goes wrong with the code. Any idea?

Ivan
 
joel

Finally, the code works flawlessly. As told, I copy the code again from the
below URL and now no more over-write issue.

I really really appreciated your help and step-by-step guidance.

Thank you very much!
Ivan
 
I did this and it tested fine. Format your sheet 3.
I can send the workbook,if desired.

Sub GetDataSAS()
Application.ScreenUpdating = False
Set cs = Sheets("sheet1")
Set ds = Sheets("sheet3")
getdate:
ans = InputBox("Enter a proper date: ex: 7/1/2009 " & vbCr & " or touch the
enter key for ALL")
On Error GoTo doall
Set mycol = cs.Rows(1).Find(what:=CDate(ans), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext,
_
MatchCase:=False)
If mycol Is Nothing Then GoTo getdate
doall:
If ans = "" Then
mc = 0
Else
mc = mycol.Column
End If
'MsgBox mc
If mc = 0 Then
dlr = ds.Cells(Rows.Count, 1).End(xlUp).Row
ds.Rows(2).Resize(dlr).Delete
x = 3: y = cs.Cells(1, Columns.Count).End(xlToLeft).Column
Else
x = mc: y = mc
End If

For Each ws In Array("sheet1", "sheet2")
Set ss = Sheets(ws)
For j = 2 To ss.Cells(Rows.Count, 1).End(xlUp).Row
For i = x To y
dlr = ds.Cells(Rows.Count, 1).End(xlUp).Row + 1
If ss.Cells(j, i) > 0 Then
ds.Cells(dlr, 1).Value = ss.Cells(j, 1).Value
ds.Cells(dlr, 2).Value = ss.Cells(j, 2).Value
ds.Cells(dlr, 3).Value = ss.Cells(1, i).Value
ds.Cells(dlr, 4).Value = ss.Cells(j, i).Value

End If
Next i
Next j
Next ws
dlr = ds.Cells(Rows.Count, 1).End(xlUp).Row
ds.Range("A1:D" & dlr).Sort _
Key1:=ds.Range("C2"), Order1:=xlAscending, _
Key2:=ds.Range("B2"), Order2:=xlAscending, _
Key3:=ds.Range("A2"), Order3:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
Application.ScreenUpdating = True
End Sub
 
Wonderful!...thank you both...you both worked!

Ivan

Don Guillett said:
I did this and it tested fine. Format your sheet 3.
I can send the workbook,if desired.

Sub GetDataSAS()
Application.ScreenUpdating = False
Set cs = Sheets("sheet1")
Set ds = Sheets("sheet3")
getdate:
ans = InputBox("Enter a proper date: ex: 7/1/2009 " & vbCr & " or touch
the enter key for ALL")
On Error GoTo doall
Set mycol = cs.Rows(1).Find(what:=CDate(ans), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext,
_
MatchCase:=False)
If mycol Is Nothing Then GoTo getdate
doall:
If ans = "" Then
mc = 0
Else
mc = mycol.Column
End If
'MsgBox mc
If mc = 0 Then
dlr = ds.Cells(Rows.Count, 1).End(xlUp).Row
ds.Rows(2).Resize(dlr).Delete
x = 3: y = cs.Cells(1, Columns.Count).End(xlToLeft).Column
Else
x = mc: y = mc
End If

For Each ws In Array("sheet1", "sheet2")
Set ss = Sheets(ws)
For j = 2 To ss.Cells(Rows.Count, 1).End(xlUp).Row
For i = x To y
dlr = ds.Cells(Rows.Count, 1).End(xlUp).Row + 1
If ss.Cells(j, i) > 0 Then
ds.Cells(dlr, 1).Value = ss.Cells(j, 1).Value
ds.Cells(dlr, 2).Value = ss.Cells(j, 2).Value
ds.Cells(dlr, 3).Value = ss.Cells(1, i).Value
ds.Cells(dlr, 4).Value = ss.Cells(j, i).Value

End If
Next i
Next j
Next ws
dlr = ds.Cells(Rows.Count, 1).End(xlUp).Row
ds.Range("A1:D" & dlr).Sort _
Key1:=ds.Range("C2"), Order1:=xlAscending, _
Key2:=ds.Range("B2"), Order2:=xlAscending, _
Key3:=ds.Range("A2"), Order3:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
Application.ScreenUpdating = True
End Sub

--
Don Guillett
Microsoft MVP Excel
SalesAid Software
(e-mail address removed)
joel said:
Don: All the code that I posted had the dots. for some reason some of
the replies are missing the dots. I can't see what I did wrong that the
code is reading and writing to sheet2 without the select.

Ivan: check you code and make sure the al the Methods below start with
a period:

Range
Columns
Cells


Ivan if you are not getting the code from the CodeCage try this URL

http://www.thecodecage.com/forumz/newreply.php?do=newreply&p=597160


--
joel
------------------------------------------------------------------------
joel's Profile: 229
View this thread:
http://www.thecodecage.com/forumz/showthread.php?t=165248

Microsoft Office Help
Click to expand...
Click to expand...
 
Back
Top