Excel Vba copy same date to list of entries

A

aneela1

New member
Joined
Nov 21, 2015
Messages
47
Reaction score
0
Points
0
Hi,
I am copying a list of cell entries from invoice to ledger using vba. All the copied entries must have the same date as copied from the invoice sheet to the ledger sheet(per use of button).
The next time the button is clicked, it should copy to the next empty rows on ledger sheet. Please help me with this. I cannot seem to get the date which is cell I5, to be copied against all the entries in Column A.

Also for the ledger, I want it to print statement for a user defined period, say 01 Jan 2014 to 01 Jan 2015 or randomly such as 12 April 2015 to 12 May 2015. Please help on that also.

Thank you

Truly,
Aneela
Thank you

Truly,
Aneela
 

Attachments

  • invoice.xlsm
    21.8 KB · Views: 15
  • ledger.xlsx
    12.4 KB · Views: 18
Try the following (it has some changes I made which you may need to change back)
Code: 
Sub Button1_click()

Set wb1 = ThisWorkbook
Set ws1 = wb1.Sheets("Invoice")
Dim v As String
Dim wb As String
Const sPath As String = "F:\Software\"

LastSrceRow = ws1.Range("B25").End(xlUp).Row
v = "Ledger"  'ws1.Range("A5").Value 'you may need to alter this line..
wb = v & ".xlsx"
Workbooks.Open sPath & v & ".xlsx"
nxtRw = Sheets("Ledger").Range("B" & Rows.Count).End(xlUp).Row + 1

ws1.Range("B10:B" & LastSrceRow).Copy
Workbooks(wb).Sheets("Ledger").Range("D" & nxtRw).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

ws1.Range("G10:G" & LastSrceRow).Copy
Workbooks(wb).Sheets("Ledger").Range("C" & nxtRw).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

ws1.Range("H10:H" & LastSrceRow).Copy
Workbooks(wb).Sheets("Ledger").Range("I" & nxtRw).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

ws1.Range("I10:I" & LastSrceRow).Copy
Workbooks(wb).Sheets("Ledger").Range("J" & nxtRw).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

ws1.Range("I5:I6").Copy
Workbooks(wb).Sheets("Ledger").Range("A" & nxtRw).Resize(LastSrceRow - 9, 2).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

End Sub
Regarding printing only certain date ranges, you can select all the header cells on row 9 (normally one cell would do but that doesn't seem to work well, it filters starting from the row below - probably because of merged cells?) and click (Auto)Filter on the Data tab of the ribbon, then in the date drop down look for the Date Filters option where you have a wealth of ways of filtering by date.
 
Last edited:
I am sorry. I did not know that cross-posting was not allowed. I apologize. Thank you.
 
aneela1 said:
I am sorry. I did not know that cross-posting was not allowed. I apologize. Thank you.
Click to expand...
Cross-posting is allowed (read the link) but if you must do it you must supply links to where you have cross posted (it's the same rule at most or all of the sites you've cross posted at).
 
@p45cal Thank you. It does work. but it has some issues:

1. invoice.xlsm has 15 rows where user can enter the data to be copied to ledger.xlsx, but if there are less than 15 items on the invoice, say 10 or 2, it still copies the date for 15 entries onto the ledgerPlease help with that.

2. The number of rows in Column D for ledger.xlsx is 32(for A4 printing). If 15 items one time and then 15 items are added, only 2 rows are left. if a user enters more than 2 items excel errors and says that the size should be identical.

Please could you:

a. stop the copying process when the final limit of cell D43 is hit
b. ask the user to print the current worksheet(which is full)
c. add another worksheet to the workbook ledger for new copying and rename the current sheet.
 
aneela1 said:
It does work. but it has some issues:
1. invoice.xlsm has 15 rows where user can enter the data to be copied to ledger.xlsx, but if there are less than 15 items on the invoice, say 10 or 2, it still copies the date for 15 entries onto the ledgerPlease help with that.
Click to expand...
I thought I had catered specifically for that (and tested on your sample file) with:
LastSrceRow = ws1.Range("B25").End(xlUp).Row
but maybe there is something in cells B24 and above which appear blank but are not; you can confirm by emulating what the code does by selecting cell B25, pressing the End key on the keyboard followed by the up-arrow on the keyboard. Is the last cell with data in column B not now selected?

aneela1 said:
2. The number of rows in Column D for ledger.xlsx is 32(for A4 printing). If 15 items one time and then 15 items are added, only 2 rows are left. if a user enters more than 2 items excel errors and says that the size should be identical.

Please could you:

a. stop the copying process when the final limit of cell D43 is hit
Click to expand...
Code: 
Sub Button1_click()
Set wb1 = ThisWorkbook
Set ws1 = wb1.Sheets("Invoice")
Dim v As String
Dim wb As String
Const sPath As String = "F:\Software\"

LastSrceRow = ws1.Range("B25").End(xlUp).Row
v = "Ledger"  'ws1.Range("A5").Value
wb = v & ".xlsx"
Workbooks.Open sPath & v & ".xlsx"
nxtRw = Sheets("Ledger").Range("B" & Rows.Count).End(xlUp).Row + 1
If nxtRw + LastSrceRow - 10 > 43 Then
  MsgBox "Too many rows to copy - aborting copy"
Else
  ws1.Range("B10:B" & LastSrceRow).Copy
  Workbooks(wb).Sheets("Ledger").Range("D" & nxtRw).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

  ws1.Range("G10:G" & LastSrceRow).Copy
  Workbooks(wb).Sheets("Ledger").Range("C" & nxtRw).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

  ws1.Range("H10:H" & LastSrceRow).Copy
  Workbooks(wb).Sheets("Ledger").Range("I" & nxtRw).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

  ws1.Range("I10:I" & LastSrceRow).Copy
  Workbooks(wb).Sheets("Ledger").Range("J" & nxtRw).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

  ws1.Range("I5:I6").Copy
  Workbooks(wb).Sheets("Ledger").Range("A" & nxtRw).Resize(LastSrceRow - 9, 2).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End If
End Sub
aneela1 said:
b. ask the user to print the current worksheet(which is full)
c. add another worksheet to the workbook ledger for new copying and rename the current sheet.
Click to expand...
Out of time for that - create a new thread perhaps?
 
Last edited:
You must log in or register to reply here.
Back
Top