Select / Copy / Paste

S

Seeker

Need help in following VBA
Wb 2 sheets named as “AA†& “BBâ€.
Wb1, Sheet 1, col E = date, col D = InvoiceNo, col B = Names,
I need to copy wb1 range col D to col K of row(s) found which col B are “AAâ€
& “BB†only and col E = today and col D (InvoiceNo) not a duplication in wb2.
When transfer data from wb1 to wb2, place in the sheet with same name as col
B.
Tks & Rgds
 
P

Per Jessen

HI

Try this:

Sub TransferData()
Dim wbA As Workbook
Dim wbB As Workbook
Dim shAA As Worksheet
Dim shBB As Worksheet
Dim shData As Worksheet
Dim FilterRng As Range

Set wbA = Workbooks("Book1.xls") 'Change to suit
Set wbB = Workbooks("Book2.xls") 'Change to suit
Set shAA = wbB.Worksheets("AA")
Set shBB = wbB.Worksheets("BB")
Set shData = wbA.Worksheets("Sheet1")
Set FilterRng = shData.Range("B1:E" & shData.Range("B" &
Rows.Count).End(xlUp).Row)

Application.ScreenUpdating = False
FilterRng.AutoFilter field:=1, Criteria1:="AA", field:=2, Criteria2:=Date
For Each rw In FilterRng.SpecialCells(xlCellTypeVisible).Row
InvNum = shData.Range("D" & rw)
Set f = shAA.Cells.Find(what:=InvNum, after:=shAA.Range("A1"),
lookat:=xlWhole)
If f Is Nothing Then
shData.Range("D" & rw, shData.Range("K" & rw)).Copy shAA.Range("A" &
Rows.Count).End(xlUp).Offset(1)
Else
Set f = Nothing
End If
Next

FilterRng.AutoFilter field:=1, Criteria1:="BB", field:=2, Criteria2:=Date
For Each rw In FilterRng.SpecialCells(xlCellTypeVisible).Row
InvNum = shData.Range("D" & rw)
Set f = shAA.Cells.Find(what:=InvNum, after:=shBB.Range("A1"),
lookat:=xlWhole)
If f Is Nothing Then
shData.Range("D" & rw, shData.Range("K" & rw)).Copy shBB.Range("A" &
Rows.Count).End(xlUp).Offset(1)
Else
Set f = Nothing
End If
Next
FilterRng.AutoFilter
Application.ScreenUpdating = True
End Sub

Regards,
Per
 
J

JLatham

I believe that the following code, plased in WB 2 (one with AA and BB sheets
in it) will do the trick for you. You should make a copy of that workbook to
test with, just to protect yourself from any mistake I may have made! I've
only tested it with very minimal data.

To use it, open that workbook and run the macro, it will ask you to browse
to find the other workbook and once you do that, it will open the other
workbook and copy over any new AA/BB invoices that are dated the same as
"today" and that have invoice numbers that don't already exist on sheets
AA/BB.

To put the code into that workbook, open it up and press [Alt]+[F11] to open
the VB Editor and then choose Insert --> Module. Copy the code below and
paste it into the code module. Look for any red lines of entry - those would
be ones that got broken up improperly by the editor in this forum.

The code:

Sub CopyNewInvoices()
Const ws1Name = "AA"
Const ws2Name = "BB"
Const NameCol = "B"
Const InvNoCol = "D"
Const InvDateCol = "E"
Const FirstColToCopy = "D"
Const LastColToCopy = "K"

Dim WB1Name As String
Dim WB1 As Workbook
Dim WS1 As Worksheet
Dim WS1NamesRange As Range
Dim anyWS1Name As Range
Dim WB2 As Workbook
Dim WB2WS As Worksheet
Dim WB2CurrentInvoices As Range
Dim anyWB2Invoice As Range
Dim offset2InvNo As Integer
Dim offset2Date As Integer
Dim foundFlag As Boolean
Dim sourceRange As Range
Dim destRange As Range
Dim nextWB2Row As Long

WB1Name = Application.GetOpenFilename
If WB1Name = "False" Then
MsgBox "No File Selected. Quitting.", _
vbOKOnly + vbInformation, _
"File Select Cancelled by User"
Exit Sub
End If
Application.ScreenUpdating = False
'open the other workbook without updating links
'and in Read Only mode
Application.DisplayAlerts = False
Set WB1 = Workbooks.Open(WB1Name, False, True)
Application.DisplayAlerts = True
Set WS1 = WB1.Worksheets(1)
Set WS1NamesRange = WS1.Range(NameCol & "1:" & _
WS1.Range(NameCol & Rows.Count).End(xlUp).Address)
offset2InvNo = Range(InvNoCol & 1).Column - _
Range(NameCol & 1).Column
offset2Date = Range(InvDateCol & 1).Column - _
Range(NameCol & 1).Column

Set WB2 = ThisWorkbook
WB2.Activate
'begin the real work
For Each anyWS1Name In WS1NamesRange
Select Case UCase(Trim(anyWS1Name))
Case Is = ws1Name
'goes to sheet AA
'IF the date is today
If anyWS1Name.Offset(0, offset2Date) = Date Then
'now must make sure invoice number does no
'already exist in this workbook (WB2)
Set WB2WS = WB2.Worksheets(ws1Name)
Set WB2CurrentInvoices = WB2WS.Range(InvNoCol _
& "1:" & WB2WS.Range(InvNoCol _
& Rows.Count).End(xlUp).Address)
foundFlag = False
For Each anyWB2Invoice In WB2CurrentInvoices
If anyWB2Invoice = _
anyWS1Name.Offset(0, offset2InvNo) Then
foundFlag = True
Exit For
End If
Next
If Not foundFlag Then
'this is a new entry, make it!
Set sourceRange = WS1.Range(FirstColToCopy & _
anyWS1Name.Row & ":" _
& LastColToCopy & anyWS1Name.Row)
nextWB2Row = WB2WS.Range(FirstColToCopy & _
Rows.Count).End(xlUp).Row + 1
Set destRange = WB2WS.Range(FirstColToCopy & _
nextWB2Row & ":" _
& LastColToCopy & nextWB2Row)
destRange.Value = sourceRange.Value
End If
End If

Case Is = ws2Name
'goes to sheet BB
'IF the date is today
If anyWS1Name.Offset(0, offset2Date) = Date Then
Set WB2WS = WB2.Worksheets(ws2Name)
Set WB2CurrentInvoices = WB2WS.Range(InvNoCol _
& "1:" & WB2WS.Range(InvNoCol _
& Rows.Count).End(xlUp).Address)
foundFlag = False
For Each anyWB2Invoice In WB2CurrentInvoices
If anyWB2Invoice = _
anyWS1Name.Offset(0, offset2InvNo) Then
foundFlag = True
Exit For
End If
Next
If Not foundFlag Then
'this is a new entry, make it!
Set sourceRange = WS1.Range(FirstColToCopy & _
anyWS1Name.Row & ":" _
& LastColToCopy & anyWS1Name.Row)
nextWB2Row = WB2WS.Range(FirstColToCopy & _
Rows.Count).End(xlUp).Row + 1
Set destRange = WB2WS.Range(FirstColToCopy & _
nextWB2Row & ":" _
& LastColToCopy & nextWB2Row)
destRange.Value = sourceRange.Value
End If
End If

Case Else
'do nothing
End Select
Next
'cleanup and finish
Set sourceRange = Nothing
Set destRange = Nothing
Set WS1 = Nothing
WB1.Close False ' close without saving changes
Set WB1 = Nothing
Set WB2 = Nothing
MsgBox "New Invoice Copying Completed.", _
vbOKOnly + vbInformation, "Task Completed"
End Sub
 
J

JLatham

I tried posting this earlier, apparently didn't stick. So...

Make a copy of your 'Wb 2' with the AA/BB sheets in it. Open it up, press
[Alt]+[F11] to enter the VB Editor. Choose Insert --> Module and then copy
the code below into the code module and close the VB Editor. Run the macro
with the other workbook NOT open initially. The code will ask you to choose
that other workbook, then open it and do the work and close the other
workbook for you.

I've tested this with absolute minimum data, so I know it runs, but I
wouldn't call it thoroughly tested. Here's the code:

Sub CopyNewInvoices()
Const ws1Name = "AA"
Const ws2Name = "BB"
Const NameCol = "B"
Const InvNoCol = "D"
Const InvDateCol = "E"
Const FirstColToCopy = "D"
Const LastColToCopy = "K"

Dim WB1Name As String
Dim WB1 As Workbook
Dim WS1 As Worksheet
Dim WS1NamesRange As Range
Dim anyWS1Name As Range
Dim WB2 As Workbook
Dim WB2WS As Worksheet
Dim WB2CurrentInvoices As Range
Dim anyWB2Invoice As Range
Dim offset2InvNo As Integer
Dim offset2Date As Integer
Dim foundFlag As Boolean
Dim sourceRange As Range
Dim destRange As Range
Dim nextWB2Row As Long

WB1Name = Application.GetOpenFilename
If WB1Name = "False" Then
MsgBox "No File Selected. Quitting.", _
vbOKOnly + vbInformation, _
"File Select Cancelled by User"
Exit Sub
End If
Application.ScreenUpdating = False
'open the other workbook without updating links
'and in Read Only mode
Application.DisplayAlerts = False
Set WB1 = Workbooks.Open(WB1Name, False, True)
Application.DisplayAlerts = True
Set WS1 = WB1.Worksheets(1)
Set WS1NamesRange = WS1.Range(NameCol & "1:" & _
WS1.Range(NameCol & Rows.Count).End(xlUp).Address)
offset2InvNo = Range(InvNoCol & 1).Column - _
Range(NameCol & 1).Column
offset2Date = Range(InvDateCol & 1).Column - _
Range(NameCol & 1).Column

Set WB2 = ThisWorkbook
WB2.Activate
'begin the real work
For Each anyWS1Name In WS1NamesRange
Select Case UCase(Trim(anyWS1Name))
Case Is = ws1Name
'goes to sheet AA
'IF the date is today
If anyWS1Name.Offset(0, offset2Date) = Date Then
'now must make sure invoice number does no
'already exist in this workbook (WB2)
Set WB2WS = WB2.Worksheets(ws1Name)
Set WB2CurrentInvoices = WB2WS.Range(InvNoCol _
& "1:" & WB2WS.Range(InvNoCol _
& Rows.Count).End(xlUp).Address)
foundFlag = False
For Each anyWB2Invoice In WB2CurrentInvoices
If anyWB2Invoice = _
anyWS1Name.Offset(0, offset2InvNo) Then
foundFlag = True
Exit For
End If
Next
If Not foundFlag Then
'this is a new entry, make it!
Set sourceRange = WS1.Range(FirstColToCopy & _
anyWS1Name.Row & ":" _
& LastColToCopy & anyWS1Name.Row)
nextWB2Row = WB2WS.Range(FirstColToCopy & _
Rows.Count).End(xlUp).Row + 1
Set destRange = WB2WS.Range(FirstColToCopy & _
nextWB2Row & ":" _
& LastColToCopy & nextWB2Row)
destRange.Value = sourceRange.Value
End If
End If

Case Is = ws2Name
'goes to sheet BB
'IF the date is today
If anyWS1Name.Offset(0, offset2Date) = Date Then
Set WB2WS = WB2.Worksheets(ws2Name)
Set WB2CurrentInvoices = WB2WS.Range(InvNoCol _
& "1:" & WB2WS.Range(InvNoCol _
& Rows.Count).End(xlUp).Address)
foundFlag = False
For Each anyWB2Invoice In WB2CurrentInvoices
If anyWB2Invoice = _
anyWS1Name.Offset(0, offset2InvNo) Then
foundFlag = True
Exit For
End If
Next
If Not foundFlag Then
'this is a new entry, make it!
Set sourceRange = WS1.Range(FirstColToCopy & _
anyWS1Name.Row & ":" _
& LastColToCopy & anyWS1Name.Row)
nextWB2Row = WB2WS.Range(FirstColToCopy & _
Rows.Count).End(xlUp).Row + 1
Set destRange = WB2WS.Range(FirstColToCopy & _
nextWB2Row & ":" _
& LastColToCopy & nextWB2Row)
destRange.Value = sourceRange.Value
End If
End If

Case Else
'do nothing
End Select
Next
'cleanup and finish
Set sourceRange = Nothing
Set destRange = Nothing
Set WS1 = Nothing
WB1.Close False ' close without saving changes
Set WB1 = Nothing
Set WB2 = Nothing
MsgBox "New Invoice Copying Completed.", _
vbOKOnly + vbInformation, "Task Completed"

End Sub
 
R

Rick Rothstein

Just so you know, I can see both of your messages.

--
Rick (MVP - Excel)



JLatham said:
I tried posting this earlier, apparently didn't stick. So...

Make a copy of your 'Wb 2' with the AA/BB sheets in it. Open it up, press
[Alt]+[F11] to enter the VB Editor. Choose Insert --> Module and then
copy
the code below into the code module and close the VB Editor. Run the
macro
with the other workbook NOT open initially. The code will ask you to
choose
that other workbook, then open it and do the work and close the other
workbook for you.

I've tested this with absolute minimum data, so I know it runs, but I
wouldn't call it thoroughly tested. Here's the code:

Sub CopyNewInvoices()
Const ws1Name = "AA"
Const ws2Name = "BB"
Const NameCol = "B"
Const InvNoCol = "D"
Const InvDateCol = "E"
Const FirstColToCopy = "D"
Const LastColToCopy = "K"

Dim WB1Name As String
Dim WB1 As Workbook
Dim WS1 As Worksheet
Dim WS1NamesRange As Range
Dim anyWS1Name As Range
Dim WB2 As Workbook
Dim WB2WS As Worksheet
Dim WB2CurrentInvoices As Range
Dim anyWB2Invoice As Range
Dim offset2InvNo As Integer
Dim offset2Date As Integer
Dim foundFlag As Boolean
Dim sourceRange As Range
Dim destRange As Range
Dim nextWB2Row As Long

WB1Name = Application.GetOpenFilename
If WB1Name = "False" Then
MsgBox "No File Selected. Quitting.", _
vbOKOnly + vbInformation, _
"File Select Cancelled by User"
Exit Sub
End If
Application.ScreenUpdating = False
'open the other workbook without updating links
'and in Read Only mode
Application.DisplayAlerts = False
Set WB1 = Workbooks.Open(WB1Name, False, True)
Application.DisplayAlerts = True
Set WS1 = WB1.Worksheets(1)
Set WS1NamesRange = WS1.Range(NameCol & "1:" & _
WS1.Range(NameCol & Rows.Count).End(xlUp).Address)
offset2InvNo = Range(InvNoCol & 1).Column - _
Range(NameCol & 1).Column
offset2Date = Range(InvDateCol & 1).Column - _
Range(NameCol & 1).Column

Set WB2 = ThisWorkbook
WB2.Activate
'begin the real work
For Each anyWS1Name In WS1NamesRange
Select Case UCase(Trim(anyWS1Name))
Case Is = ws1Name
'goes to sheet AA
'IF the date is today
If anyWS1Name.Offset(0, offset2Date) = Date Then
'now must make sure invoice number does no
'already exist in this workbook (WB2)
Set WB2WS = WB2.Worksheets(ws1Name)
Set WB2CurrentInvoices = WB2WS.Range(InvNoCol _
& "1:" & WB2WS.Range(InvNoCol _
& Rows.Count).End(xlUp).Address)
foundFlag = False
For Each anyWB2Invoice In WB2CurrentInvoices
If anyWB2Invoice = _
anyWS1Name.Offset(0, offset2InvNo) Then
foundFlag = True
Exit For
End If
Next
If Not foundFlag Then
'this is a new entry, make it!
Set sourceRange = WS1.Range(FirstColToCopy & _
anyWS1Name.Row & ":" _
& LastColToCopy & anyWS1Name.Row)
nextWB2Row = WB2WS.Range(FirstColToCopy & _
Rows.Count).End(xlUp).Row + 1
Set destRange = WB2WS.Range(FirstColToCopy & _
nextWB2Row & ":" _
& LastColToCopy & nextWB2Row)
destRange.Value = sourceRange.Value
End If
End If

Case Is = ws2Name
'goes to sheet BB
'IF the date is today
If anyWS1Name.Offset(0, offset2Date) = Date Then
Set WB2WS = WB2.Worksheets(ws2Name)
Set WB2CurrentInvoices = WB2WS.Range(InvNoCol _
& "1:" & WB2WS.Range(InvNoCol _
& Rows.Count).End(xlUp).Address)
foundFlag = False
For Each anyWB2Invoice In WB2CurrentInvoices
If anyWB2Invoice = _
anyWS1Name.Offset(0, offset2InvNo) Then
foundFlag = True
Exit For
End If
Next
If Not foundFlag Then
'this is a new entry, make it!
Set sourceRange = WS1.Range(FirstColToCopy & _
anyWS1Name.Row & ":" _
& LastColToCopy & anyWS1Name.Row)
nextWB2Row = WB2WS.Range(FirstColToCopy & _
Rows.Count).End(xlUp).Row + 1
Set destRange = WB2WS.Range(FirstColToCopy & _
nextWB2Row & ":" _
& LastColToCopy & nextWB2Row)
destRange.Value = sourceRange.Value
End If
End If

Case Else
'do nothing
End Select
Next
'cleanup and finish
Set sourceRange = Nothing
Set destRange = Nothing
Set WS1 = Nothing
WB1.Close False ' close without saving changes
Set WB1 = Nothing
Set WB2 = Nothing
MsgBox "New Invoice Copying Completed.", _
vbOKOnly + vbInformation, "Task Completed"

End Sub


Seeker said:
Need help in following VBA
Wb 2 sheets named as “AA†& “BBâ€.
Wb1, Sheet 1, col E = date, col D = InvoiceNo, col B = Names,
I need to copy wb1 range col D to col K of row(s) found which col B are
“AAâ€
& “BB†only and col E = today and col D (InvoiceNo) not a duplication in
wb2.
When transfer data from wb1 to wb2, place in the sheet with same name as
col
B.
Tks & Rgds
Click to expand...
Click to expand...
 
S

Seeker

Hi Per Jessen,
First of all thank you very much for your code. Please excuse my late reply
as I just finished in this project.
I meet difficulties in modifying your code to finish my project. The most
difficult part was checking if “InvNum†already exist or not in the shAA &
shBB. However, with the enlightenment in employing the filter, I added a
dummy column with match formula and I am able to get the target result.
Once again, thanks for your help.
Rgds
 
S

Seeker

Hi JLatham,
Your code is much appreciated as it must have taken a lot of your time and
great efforts. With regret that I did not adopt your code, I am unable to
modify your profound codes in fitting my needs. I understand that there isn’t
anything wrong in your code but only was your profound codes just far beyond
the limited knowledge in my beginner phase. However, I have bookmarked this
thread for my future usages. Once again … thank you for your assistance in
this coding.
Rgds


JLatham said:
I believe that the following code, plased in WB 2 (one with AA and BB sheets
in it) will do the trick for you. You should make a copy of that workbook to
test with, just to protect yourself from any mistake I may have made! I've
only tested it with very minimal data.

To use it, open that workbook and run the macro, it will ask you to browse
to find the other workbook and once you do that, it will open the other
workbook and copy over any new AA/BB invoices that are dated the same as
"today" and that have invoice numbers that don't already exist on sheets
AA/BB.

To put the code into that workbook, open it up and press [Alt]+[F11] to open
the VB Editor and then choose Insert --> Module. Copy the code below and
paste it into the code module. Look for any red lines of entry - those would
be ones that got broken up improperly by the editor in this forum.

The code:

Sub CopyNewInvoices()
Const ws1Name = "AA"
Const ws2Name = "BB"
Const NameCol = "B"
Const InvNoCol = "D"
Const InvDateCol = "E"
Const FirstColToCopy = "D"
Const LastColToCopy = "K"

Dim WB1Name As String
Dim WB1 As Workbook
Dim WS1 As Worksheet
Dim WS1NamesRange As Range
Dim anyWS1Name As Range
Dim WB2 As Workbook
Dim WB2WS As Worksheet
Dim WB2CurrentInvoices As Range
Dim anyWB2Invoice As Range
Dim offset2InvNo As Integer
Dim offset2Date As Integer
Dim foundFlag As Boolean
Dim sourceRange As Range
Dim destRange As Range
Dim nextWB2Row As Long

WB1Name = Application.GetOpenFilename
If WB1Name = "False" Then
MsgBox "No File Selected. Quitting.", _
vbOKOnly + vbInformation, _
"File Select Cancelled by User"
Exit Sub
End If
Application.ScreenUpdating = False
'open the other workbook without updating links
'and in Read Only mode
Application.DisplayAlerts = False
Set WB1 = Workbooks.Open(WB1Name, False, True)
Application.DisplayAlerts = True
Set WS1 = WB1.Worksheets(1)
Set WS1NamesRange = WS1.Range(NameCol & "1:" & _
WS1.Range(NameCol & Rows.Count).End(xlUp).Address)
offset2InvNo = Range(InvNoCol & 1).Column - _
Range(NameCol & 1).Column
offset2Date = Range(InvDateCol & 1).Column - _
Range(NameCol & 1).Column

Set WB2 = ThisWorkbook
WB2.Activate
'begin the real work
For Each anyWS1Name In WS1NamesRange
Select Case UCase(Trim(anyWS1Name))
Case Is = ws1Name
'goes to sheet AA
'IF the date is today
If anyWS1Name.Offset(0, offset2Date) = Date Then
'now must make sure invoice number does no
'already exist in this workbook (WB2)
Set WB2WS = WB2.Worksheets(ws1Name)
Set WB2CurrentInvoices = WB2WS.Range(InvNoCol _
& "1:" & WB2WS.Range(InvNoCol _
& Rows.Count).End(xlUp).Address)
foundFlag = False
For Each anyWB2Invoice In WB2CurrentInvoices
If anyWB2Invoice = _
anyWS1Name.Offset(0, offset2InvNo) Then
foundFlag = True
Exit For
End If
Next
If Not foundFlag Then
'this is a new entry, make it!
Set sourceRange = WS1.Range(FirstColToCopy & _
anyWS1Name.Row & ":" _
& LastColToCopy & anyWS1Name.Row)
nextWB2Row = WB2WS.Range(FirstColToCopy & _
Rows.Count).End(xlUp).Row + 1
Set destRange = WB2WS.Range(FirstColToCopy & _
nextWB2Row & ":" _
& LastColToCopy & nextWB2Row)
destRange.Value = sourceRange.Value
End If
End If

Case Is = ws2Name
'goes to sheet BB
'IF the date is today
If anyWS1Name.Offset(0, offset2Date) = Date Then
Set WB2WS = WB2.Worksheets(ws2Name)
Set WB2CurrentInvoices = WB2WS.Range(InvNoCol _
& "1:" & WB2WS.Range(InvNoCol _
& Rows.Count).End(xlUp).Address)
foundFlag = False
For Each anyWB2Invoice In WB2CurrentInvoices
If anyWB2Invoice = _
anyWS1Name.Offset(0, offset2InvNo) Then
foundFlag = True
Exit For
End If
Next
If Not foundFlag Then
'this is a new entry, make it!
Set sourceRange = WS1.Range(FirstColToCopy & _
anyWS1Name.Row & ":" _
& LastColToCopy & anyWS1Name.Row)
nextWB2Row = WB2WS.Range(FirstColToCopy & _
Rows.Count).End(xlUp).Row + 1
Set destRange = WB2WS.Range(FirstColToCopy & _
nextWB2Row & ":" _
& LastColToCopy & nextWB2Row)
destRange.Value = sourceRange.Value
End If
End If

Case Else
'do nothing
End Select
Next
'cleanup and finish
Set sourceRange = Nothing
Set destRange = Nothing
Set WS1 = Nothing
WB1.Close False ' close without saving changes
Set WB1 = Nothing
Set WB2 = Nothing
MsgBox "New Invoice Copying Completed.", _
vbOKOnly + vbInformation, "Task Completed"
End Sub


Seeker said:
Need help in following VBA
Wb 2 sheets named as “AA†& “BBâ€.
Wb1, Sheet 1, col E = date, col D = InvoiceNo, col B = Names,
I need to copy wb1 range col D to col K of row(s) found which col B are “AAâ€
& “BB†only and col E = today and col D (InvoiceNo) not a duplication in wb2.
When transfer data from wb1 to wb2, place in the sheet with same name as col
B.
Tks & Rgds
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

comment copy 3
Sheet Cleanup Help Please 5
Transpose & reorg data from 2 WS to new WB 2
Code Reqd. to generate Loading Slip 3
Help needed with setting up a complex directive 1
Copy/Paste based on Criteria 2
INDEX/MATCH skipping results 3
Macro !! 3

Top