Intelligent Copy Paste

[kellemr1]

I am looking to do an intelligent copy paste (dynamic). I have column A as a part number and column B as a location. Column C, D, E, F, G, H, I , J, K are quantities for each month starting with January in column C.
The problem is that Sheet 2 has the data (generated from an automatic reporting system) and Sheet 1 is, more or less, a filter that I need to develop so that I can manipulate the data further. So, I need to copy the numbers in C, D, E, F, G, etc on Sheet 2 into Sheet 1 where I specify. In order to do this, I have to compare the PN's that I have typed in on Sheet 1 to the generated PN's on Sheet 2. Once the correct part number is found, the next criteria is the location of that part. Once I find the part number and location that I want on the autmatically generated sheet, I can copy the numbers from that sheet onto my sheet (Sheet 1) next to the same part number and location that I have typed in manually.
How can I write VBA code to automatically get the quantities needed?

Remember that on Sheet 1, I have typed those part numbers in with the location. I am merely looking for a very intelligent copy and paste.


Can you or someone you know please try and help me. I have been trying for hours now before I broke down and came to this message board. I really don't know how to do this.

I have attached an attempt excel file here. These are generic numbers to replicate the problem.

[XLGibbs]

Moved to Excel forum....

Pete364 I am tied up with my 4 year odl for the next 90 minutes or so, but will be happy to take a look as we discussed in the PM's over at Mr. Excel. But I think posting it here as discussed will expose both of us to other potential solutions..

Welcome to VBAX!

[XLGibbs]

Paste this code in a code module.
Run it by pressing Alt-F8 and selecting it from the menu and hitting RUN.
or Press the green play button or F5 from the code window (or assign it to your button). Tested and works.

File with code in module 2 attached. I acounted for 12 full months in the code, even though there are not 12 months of data in your sample. The sample shows the result of the macro.

Code here:
Sub IntelligentCopyandPaste()
Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet, c As Range
Dim rngLook As Range, rngFound As Range, rngStart As Range, rngMatch As Range

Application.EnableEvents = False
On Error GoTo ErrOut

Set wb = ActiveWorkbook
Set ws1 = Sheets("Sheet1") '<===make sure is correct
Set ws2 = Sheets("Sheet2") '<==make sure is correct
With ws1
Set rngLook = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
With ws2
Set rngMatch = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With

With wb

For Each c In rngLook
Set rngFound = rngMatch.Find(c) 'find a matching part number
If Not rngFound Is Nothing Then 'if a match then do the below

Set rngStart = rngFound 'tag the first match

If c.Offset(, 1) = rngFound.Offset(, 1) Then 'if location matches then
c.Offset(, 2).Resize(1, 12).Value = rngFound.Offset(, 2).Resize(1, 12).Value
Else
Set rngFound = rngMatch.FindNext(rngFound)
If Not rngFound Is Nothing Then
Do
If c.Offset(, 1) = rngFound.Offset(, 1) Then 'if location matches then
c.Offset(, 2).Resize(1, 12).Value = rngFound.Offset(, 2).Resize(1, 12).Value
Exit Do
End If
Loop Until rngFound.Address = rngStart.Address
End If
End If
End If
Next c
End With

Set rngStart = Nothing: Set rngMatch = Nothing: Set rngLook = Nothing: Set c = Nothing
Set ws1 = Nothing: Set wb = Nothing: Set ws2 = Nothing

Application.EnableEvents = True
Exit Sub

ErrOut:
MsgBox "ooops..error" & vbNewLine & Err.Description
Err.Clear
Application.EnableEvents = True

End Sub

[XLGibbs]

By the way, the code does exactly what you need it to. Finds the part number on sheet2 (where it is automatically generated) and then checks the location for a match. On a positive match, it copies the values for all 12 columns into Sheet 1 in the appropriate row.

The only issue would be if there were duplicates of a partnum/location combination in Sheet2, but different amounts accross the columns. But that could be addressed if needed..

[kellemr1]

Wow,

That saved me enormous amounts of time.

You are very talented with VBA. I tried running the code in the spreadsheet I provided and it worked great, however, I have some problems with how the spreadsheet actually is configured. The format changed slightly (maybe an under-statement) since I have last seen the report that is automatically generated.

I attached the actual representation of the file but, sanitized. I thought maybe you could take a glance and let me know if it is possible.

How do you deal with merged cells and only one part number identification per location series?

Your code kicks a$$!! I would not have gotten as far as you did.

Any additional help would be appreciated.

[XLGibbs]

This code kicks a$$, at least for your very specific purpose.

Run this code insteand of the other code on the sample you sent me.

Sub MoreIntelligentCopyandPaste()
Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet, c As Range
Dim rngLook As Range, rngFound As Range, rngStart As Range, rngMatch As Range
Dim cs As Range
Application.EnableEvents = False
Application.ScreenUpdating = False
On Error GoTo ErrOut

Set wb = ActiveWorkbook
Set ws1 = Sheets("Conversion") '<===make sure is correct
Set ws2 = Sheets("MDS") '<==make sure is correct
With ws1
Set rngLook = .Range(.Cells(5, 2), .Cells(.Rows.Count, 2).End(xlUp))
End With

With ws2
With .Cells
'lets unmerge those cells to make life easier
.MergeCells = False
.WrapText = False
End With
lCol = .Cells(18, Columns.Count).End(xlToLeft).Column

'lets remove excess columns from the value table
For Each a In Range(Cells(18, 14), Cells(18, lCol))
If IsEmpty(a) Then a.EntireColumn.Delete
Next a

'let's set our search range
lRow = .Cells(.Rows.Count, 11).End(xlUp).Row
Set rngMatch = .Range(.Cells(19, 6), .Cells(lRow, 6).End(xlUp))

'lets replicate the values in the column to simplify the seach of the MDS table
For Each a In rngMatch
If IsEmpty(a) Then a.Value = a.Offset(-1).Value
Next a
End With

With wb

For Each c In rngLook
strC = c.Value
If IsEmpty(c) Then strC = cs.Value

Set rngFound = rngMatch.Find(strC) 'find a matching part number
If Not rngFound Is Nothing Then 'if a match then do the below
Set rngStart = rngFound 'tag the first match

If c.Offset(, 1) = rngFound.Offset(, 5) Then 'if location matches then
c.Offset(, 2).Resize(1, 12).Value = rngFound.Offset(, 8).Resize(1, 12).Value
Else
Do
Set rngFound = rngMatch.FindNext(rngFound)
If Not rngFound Is Nothing Then
If c.Offset(, 1) = rngFound.Offset(, 5) Then 'if location matches then
c.Offset(, 2).Resize(1, 12).Value = rngFound.Offset(, 8).Resize(1, 12).Value
Exit Do
End If

End If
Loop Until rngFound.Address = rngStart.Address
End If
End If
Set cs = c
Next c
End With

Set rngStart = Nothing: Set rngMatch = Nothing: Set rngLook = Nothing: Set c = Nothing
Set ws1 = Nothing: Set wb = Nothing: Set ws2 = Nothing

Application.EnableEvents = True
Exit Sub

ErrOut:
MsgBox "ooops..error" & vbNewLine & Err.Description
Err.Clear
Application.EnableEvents = True

Application.ScreenUpdating = True
End Sub


It is very taylored to your specific circumstances.

[kellemr1]

XLGibbs,

I cannot thank you enough for the code you have provided. I have been to some other forums and most people ran me into dead ends.

I now have what I need to easily run some filters.

For my own benefit, do you happen to know an easy way to replicate the numbers going up instead of down for a very specific range of numbers in one column? You had a useful code line that replicated down. I tried switching Offset(-1) to Offset(1) and it did not work, it only filled one cell.

Once again, thank you thank you thank you

[XLGibbs]

You are welcome. i think without seeing the workbook right off the bat, it would have been a very difficult solution to envisions. It required seeing the merged cells, as well as handling the varying empty columns accross the way. Being able to test it, adjust, and fire made it about a 20 minute exercise for me....and it was another interesting learning experience for me too.

To replicate a cell's value down 100 rows from A1



Range("A2:A100").Formula = Range("A1").Value
[VBA]

to do it dynamically, using offset
[VBA]
Range("A1").Offset(1,0).Resize(99,1) = Range("A1").Value


The offset (rows,cols) identifies where to go from the referenced cell. In this case (1,0) means down 1 row, and no columns. (negative is up for rows, negative is left for columns, positive is right for colums.

The resize function expands a reference to the dimensions given.

In that case it, in total, it offsets (goes down) 1 row, then expands from there to a 99 row and 1 column range.

Others:

ActiveCell.Offset(1,0).Value = ActiveCell.Value

With ActiveCell.Offset(1,0).Resize (100,1)
.Value = 123
.Font.Bold = True
.Interior.ColorIndex = 6
End with

Sheets("Sheet1").Range("A1").Resize(100,1).Formula = Sheets("Sheet2").Range("A1").Value

[kellemr1]

XL Gibbs,

I cannot get the code to perform the paste in my actual application. I run the macro and it doesn't do anything. I have looked over every aspect of this code and don't know what is wrong. It works in the example, what could be wrong? I have referenced every column and cell to make sure it is grabbing info from correct locations.

Is there some sort of script that is running in the background that could be causing any sort of problems?

The code debugger does not recognize a problem.

I was so close of being freed from my nightmare............

[XLGibbs]

If you run the macro and it doesn't actually give you a debug warning, it is working, but is likely not hitting the right column of data to loop through for matches (it would run real fast with no errors with no matches)

I would do this. Pick a line at the top of the code and highlight it by hitting the F9 key. (it will highlight with a red bar). When you run the code, it stops there. I would use the F8 key to "step through the code" step by step. If you can do it with the code window minimized in front of your spreadsheet so you can see if it is doing anything...

report back...

are the part numbers in column B of the destination sheet? are they in column F of the source data that we are looking at?

As you know it does work with the layout you sent me...(the layout of import is the sheet the code is searching through for matches)

[sureshprabhu]

Hi!
Can anybody help me to give a cell reference in another work sheet>
Thanks in advance!

[XLGibbs]

Hi!
Can anybody help me to give a cell reference in another work sheet>
Thanks in advance!

Isn't this already a new topic?


Sheets("Sheet1").Range("A1")


would refer to sheet 1, cell A1

[kellemr1]

XlGibbs,

Please take a look at the following (attached), there is no reason why it should not be finding matches. I stepped through like you said and it seems like it isn't finding matches. I manipulated your code a little bit to accomodate the data in the MDS sheet. This could be the reason although all I did was remove the code that removed all empty columns. I was able to get a format of the MDS that allowed me to not have to deleted empty columns but, everything else still applies. I changed the cell references to point to the correct range look and range match, etc for the MDS. I do not know why this is not working.

Please Help!! As you have already guessed, I am balding due to ripping my hair out.

[XLGibbs]

Will check it out shortly and post back...

[XLGibbs]

Sub MoreIntelligentCopyandPaste()
Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet, c As Range
Dim rngLook As Range, rngFound As Range, rngStart As Range, rngMatch As Range
Dim cs As Range
Application.EnableEvents = False
Application.ScreenUpdating = False
On Error GoTo ErrOut

Set wb = ActiveWorkbook
Set ws1 = Sheets("Conversion") '<===make sure is correct
Set ws2 = Sheets("MDS") '<==make sure is correct
With ws1
Set rngLook = .Range(.Cells(5, 2), .Cells(.Rows.Count, 2).End(xlUp))
End With

With ws2
With .Cells
'lets unmerge those cells to make life easier
.MergeCells = False
.WrapText = False
End With
lCol = .Cells(5, Columns.Count).End(xlToLeft).Column


'let's set our search range
lRow = .Cells(.Rows.Count, 4).End(xlUp).Row
Set rngMatch = .Range(.Cells(6, 2), .Cells(lRow, 2))

End With
MsgBox rngMatch.Address
With wb

For Each c In rngLook
If IsEmpty(c) Then
strC = strC
Else
strC = c.Value
End If
Set rngFound = rngMatch.Find(strC, LookIn:=xlPart) 'find a matching part number
If Not rngFound Is Nothing Then 'if a match then do the below

Set rngStart = rngFound 'tag the first match

If c.Offset(, 1) = rngFound.Offset(, 2) Then 'if location matches then
c.Offset(, 2).Resize(1, 12).Value = rngFound.Offset(, 3).Resize(1, 12).Value
Else
Do
Set rngFound = rngMatch.FindNext(rngFound)
If Not rngFound Is Nothing Then
If c.Offset(, 1) = rngFound.Offset(, 2) Then 'if location matches then
c.Offset(, 2).Resize(1, 12).Value = rngFound.Offset(, 3).Resize(1, 12).Value
Exit Do
End If

End If
Loop Until rngFound.Address = rngStart.Address
End If
End If



Next c
End With

Set rngStart = Nothing: Set rngMatch = Nothing: Set rngLook = Nothing: Set c = Nothing
Set ws1 = Nothing: Set wb = Nothing: Set ws2 = Nothing

Application.EnableEvents = True
Exit Sub

ErrOut:
MsgBox "ooops..error" & vbNewLine & Err.Description
Err.Clear
Application.EnableEvents = True

Application.ScreenUpdating = True
End Sub

There is code that works with your attachment. (and attached.)

The rngMatch was getting set wrong, and I tweaked another part...seems to work fine now.

[kellemr1]

Hi,

I tried the new Macro, it is faulting at the point when it gets to:
"Set rngFound = rngMatch.Find(strC, LookIn:=xlPart)"

It goes directly to the error message and says that the subscript is out of range.

Here is the funny thing, I tried it on two different computers and got two different results; one works and one does not. The really weird part is that it is working on the older version...............???????

Do you think it has anything to do with the version of excel that I have?

How could this file be "universal" if this is at all possible? I am perturbed that as soon as an excel version changes, the macro will not work.
Is 'xlPart' new to excel?

Do you have any suggestions/insight?

I really appreciate the time you have taken to help me through this.

[XLGibbs]

I have no idea, really. The last time I had this happen, it was due to versioning and apparently the references section of the VBE included a reference to Excel 12.0, which is for 2007. You can check that (or uncheck that if it is there)...

I think that the xlPart can be removed actually. It can just be .find(strC)

The whole issue was due to rngMatch not being right, which I fixed.

[benny]

Change Set rngFound = rngMatch.Find(strC, LookIn:=xlPart)

to Set rngFound = rngMatch.Find(strC, LookAt:=xlPart)

[sureshprabhu]

Hi!
I came back with another doubt, i want to put security to my sheets. In detail, I want to give authentication to each sheet to a particular user and one administrator can access total sheets. How can I do this? Help me to do this!
Thanks in advance,

[XLGibbs]

Hi!
I came back with another doubt, i want to put security to my sheets. In detail, I want to give authentication to each sheet to a particular user and one administrator can access total sheets. How can I do this? Help me to do this!
Thanks in advance,

PLease post a new topic when you have a question rather than hijack another poster's thread.

[sureshprabhu]

Hi!
How can I give a list to a particular cell which is in my masterdata sheet? In detail, I have one list in MasterData sheet, I want to give that list(Data -> Validation -> List) to a particular cell, Help me to do this!
Thanks in Advance!
SureshP

[sureshprabhu]

Oh! Sorry! I had typed something else but, i dontknow that How this was posted. So sorry!

My Doubt:
I have one list in one sheet, I named it as Masterdata. Because, I want to give list this to another cell in another sheet. Here, I mean to List is, on menu->Data->Validation->Setings->Allow, in this Allow list I want to give the address of that list which is in Masterdata sheet. Please help me to do this!
Thanks in advance!

[mdmackillop]

sureshprabhu (http://vbaexpress.com/forum/member.php?u=7996)
If you have questions, please use New Post in the Excel forum. You cannot hijack a tread in this manner.