PDA

View Full Version : copy values that aren't zero



antonyjones1
04-04-2009, 07:34 AM
Hi all I want to modify macro 20 in the attached excel spreadsheet so that it only copies values that are NOT 0. Also I want it to copy positive figures to colum D in sheet 3 and negative values to column E in sheet 3. Any suggestions?

554

Bob Phillips
04-04-2009, 09:44 AM
Which data is supposed to be copied, Sheet1? Sheet3 already has data in column D.

antonyjones1
04-04-2009, 11:19 AM
Sorry sheet 1 is the one where the data is copied from. Sheet 3 shows the results after the macro is run. If you delete the information from sheet 3 and run macro 3 you'll see that it gives the same result.

GTO
04-04-2009, 05:23 PM
Greetings,

I wasn't quite sure if you meant to only leave out the zeros, or disregard the record if the value is zero. This should just leave out the zeros, but still imports the record - while planting negative vals in Col E.


Option Explicit

Sub CopyAndAssign()

Dim _
DestSheet As Worksheet, _
SourceSheet As Worksheet, _
lngSalaryColumn As Long
lngHumptyCol As Long, _
lngTestCol As Long, _
lngLastRow As Long, _
sRow As Long, _
dRow As Long, _
sCount As Long

sCount = 0: dRow = 1

'// Set a reference to both sheets, so you don't have to worry about what sheet is //
'// active. //
Set SourceSheet = ThisWorkbook.Worksheets("Sheet1")
Set DestSheet = ThisWorkbook.Worksheets("Sheet3")

With SourceSheet

'// Find the last row once. //
lngLastRow = .Cells(Rows.Count, 2).End(xlUp).Row

'// Similarly, find "Salary", "humpty", and "test" once. //
On Error Resume Next
lngSalaryColumn = .Range("A1:Z1").Find("Salary", , , xlWhole).Column
lngHumptyCol = .Range("A1:Z1").Find("humpty", , , xlWhole).Column
lngTestCol = .Range("A1:Z1").Find("test", , , xlWhole).Column
On Error GoTo 0

'// Test to make sure we found "Salary" etc //
If lngSalaryColumn > 0 Then
For sRow = 1 To lngLastRow
If .Cells(sRow, "B") Like "*Dept. Totals" Then
sCount = sCount + 1
dRow = dRow + 1

.Cells(sRow, "A").Copy DestSheet.Cells(dRow, "C")
'// SInce we know we found "Salary", just plant the value, instead //
'// of doing another .Find ea loop. //
DestSheet.Cells(dRow, "G").Value = "Salary"

'// An IF...ELSEIF would do the same thing here. Basically, instead//
'// of copying, we see what the val is and plant it where we want //
Select Case .Cells(sRow, lngSalaryColumn).Value
Case 0
'// do nothing //
Case Is > 0
DestSheet.Cells(dRow, "D").Value = .Cells(sRow, lngSalaryColumn).Value
Case Is < 0
DestSheet.Cells(dRow, "E").Value = .Cells(sRow, lngSalaryColumn).Value
End Select
End If
Next
End If

If lngHumptyCol > 0 Then
For sRow = 1 To lngLastRow
If .Cells(sRow, "B") Like "*Dept. Totals" Then
sCount = sCount + 1
dRow = dRow + 1

.Cells(sRow, "A").Copy DestSheet.Cells(dRow, "C")
DestSheet.Cells(dRow, "G").Value = "humpty"

Select Case .Cells(sRow, lngHumptyCol).Value
Case 0
Case Is > 0
DestSheet.Cells(dRow, "D").Value = .Cells(sRow, lngHumptyCol).Value
Case Is < 0
DestSheet.Cells(dRow, "E").Value = .Cells(sRow, lngHumptyCol).Value
End Select

End If
Next
End If

If lngTestCol > 0 Then
For sRow = 1 To lngLastRow
If .Cells(sRow, "B") Like "*Dept. Totals" Then
sCount = sCount + 1
dRow = dRow + 1

.Cells(sRow, "A").Copy DestSheet.Cells(dRow, "C")
DestSheet.Cells(dRow, "G").Value = "test"

Select Case .Cells(sRow, lngTestCol).Value
Case 0
Case Is > 0
DestSheet.Cells(dRow, "D").Value = .Cells(sRow, lngTestCol).Value
Case Is < 0
DestSheet.Cells(dRow, "E").Value = .Cells(sRow, lngTestCol).Value
End Select

End If
Next
End If
End With
End Sub

Hope this helps,

Mark

antonyjones1
04-05-2009, 01:41 AM
Greetings,

I wasn't quite sure if you meant to only leave out the zeros, or disregard the record if the value is zero. This should just leave out the zeros, but still imports the record - while planting negative vals in Col E.



Hi Mark,

I don't want it to import the record if it is zero. How would the code be amended so it misses out the zeros and doesn't import the record?

GTO
04-05-2009, 04:05 AM
Greetings,

I think that just moving the counter and value assigning should do the trick. As is oft the case, we each do things a bit different, so it took me a little longer to spot this then it should have, but I don't think you were using 'sCount' anyplace, so I took that out.

Hope this works,

Mark

Sub CopyAndAssign()

Dim _
DestSheet As Worksheet, _
SourceSheet As Worksheet, _
lngSalaryColumn As Long, _
lngHumptyCol As Long, _
lngTestCol As Long, _
lngLastRow As Long, _
sRow As Long, _
dRow As Long

dRow = 1

Set SourceSheet = ThisWorkbook.Worksheets("Sheet1")
Set DestSheet = ThisWorkbook.Worksheets("Sheet3")

With SourceSheet

lngLastRow = .Cells(Rows.Count, 2).End(xlUp).Row

On Error Resume Next
lngSalaryColumn = .Range("A1:Z1").Find("Salary", , , xlWhole).Column
lngHumptyCol = .Range("A1:Z1").Find("humpty", , , xlWhole).Column
lngTestCol = .Range("A1:Z1").Find("test", , , xlWhole).Column
On Error GoTo 0

If lngSalaryColumn > 0 Then
For sRow = 1 To lngLastRow
If .Cells(sRow, "B") Like "*Dept. Totals" Then
'sCount = sCount + 1
Select Case .Cells(sRow, lngSalaryColumn).Value
Case 0
'// do nothing //
Case Is > 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = "Salary"
DestSheet.Cells(dRow, "D").Value = .Cells(sRow, lngSalaryColumn).Value
Case Is < 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = "Salary"
DestSheet.Cells(dRow, "E").Value = .Cells(sRow, lngSalaryColumn).Value
End Select
End If
Next
End If

If lngHumptyCol > 0 Then
For sRow = 1 To lngLastRow
If .Cells(sRow, "B") Like "*Dept. Totals" Then
Select Case .Cells(sRow, lngHumptyCol).Value
Case 0
Case Is > 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = "humpty"
DestSheet.Cells(dRow, "D").Value = .Cells(sRow, lngHumptyCol).Value
Case Is < 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = "humpty"
DestSheet.Cells(dRow, "E").Value = .Cells(sRow, lngHumptyCol).Value
End Select
End If
Next
End If

If lngTestCol > 0 Then
For sRow = 1 To lngLastRow
If .Cells(sRow, "B") Like "*Dept. Totals" Then
Select Case .Cells(sRow, lngTestCol).Value
Case 0
Case Is > 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = "test"
DestSheet.Cells(dRow, "D").Value = .Cells(sRow, lngTestCol).Value
Case Is < 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = "test"
DestSheet.Cells(dRow, "E").Value = .Cells(sRow, lngTestCol).Value
End Select
End If
Next
End If
End With
End Sub

antonyjones1
04-05-2009, 07:54 AM
Thanks mark it works perfectly. There's one last thing I need to be able to do. I've attached another example spreadsheet. Instead of searching for the totals of columns I want to be able to look down column recoverable and if there's values that aren't zero copy positive to D negative to E and the column title recoverable to G as normal but also put the relevant persons name in column h. The information in red on sheet 3 is what i need to do.564

GTO
04-05-2009, 07:52 PM
Hi Antony,

I am afraid you lost me. In the other tests, we first looked for (Like) Dept. Totals, then we took the records to where we wanted. In the attached wb, the records you show as being snagged do not meet this criteria.

Now, if the rules have changed for this column only (Recoverable), that would seem fine, but please specify.

Secondly, I'm thinking this part was an input error, but in L21 (Sheet1) you have both the value (4) and the name (Maggie Simpson) listed in this one cell. Am I correct in assuming the val should have been in K21?

Presuming yes on that last part, and let's say we're no longer testing for 'Dept. Totals', then try building it similar the others:
If lngRecoverableCol > 0 Then
For sRow = 2 To lngLastRow
Select Case .Cells(sRow, lngRecoverableCol).Value
Case 0
Case Is > 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = "Recoverable"
DestSheet.Cells(dRow, "H").Value = .Cells(sRow, lngRecoverableCol + 1).Value
DestSheet.Cells(dRow, "D").Value = .Cells(sRow, lngRecoverableCol).Value
Case Is < 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = "Recoverable"
DestSheet.Cells(dRow, "H").Value = .Cells(sRow, lngRecoverableCol + 1).Value
DestSheet.Cells(dRow, "E").Value = .Cells(sRow, lngRecoverableCol).Value
End Select
Next
End If


Please note that since we're not looking for Dept Totals, I subjectively started sRow at 2, in order to skip the header. Quite frankly though, this seems to start looking a little less reliable. Also, lngRecoverable needs dimmed and tested/assigned the same as the others near the top.

While I understand the data is fake, curiousity has overtaken. I sort of presumed, but still want to ask - why all the .Find(s)? Is the data sent to you and you cannot predict which column stuff will be in?

Well, hope this helps,

Mark

antonyjones1
04-06-2009, 10:41 AM
Hi Mark,

haven't had chance to play with the extra code yet but will do later on. Yuo're right 4 and Maggie simpson shouldn't have been in the same cell and the rules have only changed for column recoverable. The reason for all the find functions as you quite rightly guessed is because I need to create a journal from data that is exported into excel and this data may change which column/cell it may be in. So all the find and copies!

antonyjones1
04-16-2009, 10:37 AM
I have been using this macro without any incident until today! I get the error message "too many line continuations" when I try and add extra As Long, _. What is the best way around this? I have so far had to split the macro into 2 but would rather keep it as 1. Any suggestions as always greatly appreciated!

GTO
04-16-2009, 11:51 AM
I have been using this macro without any incident until today! I get the error message "too many line continuations" when I try and add extra As Long, _. What is the best way around this? I have so far had to split the macro into 2 but would rather keep it as 1. Any suggestions as always greatly appreciated!


Ya killed my code? Did it suffer much?

Okay, just kiddin'.

You are talking about up at the top where we dimensioned the variables. The way I layed it out is just a matter of preference, quite frankly cuz it's easy on my 48 years old eyes, and keeps the spacing when posted. Any of the below do the same thing though and you'll see that on the last one, you don't have to worry about line continuations at all.

Dim _
DestSheet As Worksheet, _
SourceSheet As Worksheet, _
lngSalaryColumn As Long, _
lngHumptyCol As Long, _
lngTestCol As Long, _
lngLastRow As Long, _
sRow As Long, _
dRow As Long, _
sCount As Long
Dim DestSheet As Worksheet, SourceSheet As Worksheet, lngSalaryColumn As Long, _
lngHumptyCol As Long, lngTestCol As Long, lngLastRow As Long, sRow As Long, _
dRow As Long, sCount As Long

Dim DestSheet As Worksheet
Dim SourceSheet As Worksheet
Dim lngSalaryColumn As Long
Dim lngHumptyCol As Long
Dim lngTestCol As Long
Dim lngLastRow As Long
Dim sRow As Long
Dim dRow As Long
Dim sCount As Long


Hope that helps,

Mark

antonyjones1
04-16-2009, 01:54 PM
Perfect Mark. Thanks again for all your help!

antonyjones1
04-17-2009, 10:37 AM
Mark,

The code works perfectly now apart from where I want to copy the individual people's info(the simpsons characters) across. Could you show me an example of the recoverable code fitted within the original code?

Also I am going to end up with a lot of Dim lng statements eventually (up to 90). Will this cause a problem? ie will hit hit the maximum size of lines a macro will allow before you have to do a second macro?

GTO
04-18-2009, 01:02 AM
The code works perfectly now apart from where I want to copy the individual people's info(the simpsons characters) across. Could you show me an example of the recoverable code fitted within the original code?

Hi Antony,

I'm not quite sure what you are asking there? Could you attach a wb with the code as we last had it and maybe a sheet that shows the outcome of copying "simpsons" across? Maybe its the long week, but I am just not clueing in to what you are doing...


Also I am going to end up with a lot of Dim lng statements eventually (up to 90). Will this cause a problem? ie will hit hit the maximum size of lines a macro will allow before you have to do a second macro?

There are others here far better qualified to answer this. My short answer would be that most often you'll be able to start re-using some variables throughout a procedure when said procedure becomes a bit lengthy.

Mark

antonyjones1
04-18-2009, 02:12 AM
Hi Mark,

Just had another play with it and actually did manage to get the new bit of code working.



If lngRecoverableCol > 0 Then
For sRow = 2 To lngLastRow
Select Case .Cells(sRow, lngRecoverableCol).Value
Case 0
Case Is > 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = "Recoverable"
DestSheet.Cells(dRow, "H").Value = .Cells(sRow, lngRecoverableCol + 1).Value
DestSheet.Cells(dRow, "D").Value = .Cells(sRow, lngRecoverableCol).Value
Case Is < 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = "Recoverable"
DestSheet.Cells(dRow, "H").Value = .Cells(sRow, lngRecoverableCol + 1).Value
DestSheet.Cells(dRow, "E").Value = .Cells(sRow, lngRecoverableCol).Value
End Select
Next
End If


So that's great. I am almost there with this now. I also took your advice and used this Dim DestSheet As Worksheet
Dim SourceSheet As Worksheet
Dim lngSalaryColumn As Long
Dim lngHumptyCol As Long
Dim lngTestCol As Long
Dim lngLastRow As Long
Dim sRow As Long
Dim dRow As Long
Dim sCount As Long

The worry I have I will have easily 90 Dim rows. With this volume I suspect I will run out of line space in the macro and have to then do a second macro. Which I am loathe to do. I'd like to keep it as 1 long macro. What is the easiest way to do this?


The attached spreadsheet shows it works!680

1 final thing I was wondering. Is there any way of modifying it so that instead of copying the cell value it pus it a formula pointing to that cell as shown in sheet2?

Sorry in advance for my poor way of explaining things!

GTO
04-19-2009, 10:00 AM
Greetings Antony,

No worries about your explanation, probably at least equally me just not "getting" it. In no particulur order:

As to max number of variables - I am unaware of a given limitation. The 'hidden' problem if you will, is that all variables take up memory. The other thing is that although I doubt you'd run any modern PC out of memory too easily, I would suspect before that, you'd start running out of meaningful names and the code becomes harder to work with. Just my opinion of course, but before a given procedure becomes long enough to make my eyes bleed, I start looking for logical breaks. This really is a matter of opinion only, leastwise strictly speaking, as the computer could care less if the code is readable, broken up into logical chunks, or one humungous procedure with the most obscure naming possible...

Sorry, but I still am not understanding your question as to "recoverable" code.

On a better note, changing to planting formulas instead of values is not too hard at all. It does seem to get a little "pickier" when referring to other workbooks. Anyways, here is the code with what I believe you were asking for.

Hope this helps,

Mark

Sub CopyAndAssign()

Dim _
DestSheet As Worksheet, _
SourceSheet As Worksheet, _
lngSalaryColumn As Long, _
lngHumptyCol As Long, _
lngTestCol As Long, _
lngLastRow As Long, _
lngrecoverableCol As Long, _
sRow As Long, _
dRow As Long

dRow = 1

Set SourceSheet = ThisWorkbook.Worksheets("Sheet1")
Set DestSheet = ThisWorkbook.Worksheets("Sheet3")

With SourceSheet

lngLastRow = .Cells(Rows.Count, 2).End(xlUp).Row

On Error Resume Next
lngSalaryColumn = .Range("A1:Z1").Find("Salary", , , xlWhole).Column
lngHumptyCol = .Range("A1:Z1").Find("humpty", , , xlWhole).Column
lngTestCol = .Range("A1:Z1").Find("test", , , xlWhole).Column
lngrecoverableCol = .Range("A1:Z1").Find("Recoverable", , , xlWhole).Column
On Error GoTo 0

If lngSalaryColumn > 0 Then
For sRow = 1 To lngLastRow
If .Cells(sRow, "B") Like "*Dept. Totals" Then
Select Case .Cells(sRow, lngSalaryColumn).Value
Case 0
'// do nothing //
Case Is > 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = "Salary"
'DestSheet.Cells(dRow, "D").Value = .Cells(sRow, lngSalaryColumn).Value
DestSheet.Cells(dRow, "D").Formula = _
"=" & .Cells(sRow, lngSalaryColumn).Parent.Name & _
"!" & .Cells(sRow, lngSalaryColumn).Address(True, True)
Case Is < 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = "Salary"
'DestSheet.Cells(dRow, "E").Value = .Cells(sRow, lngSalaryColumn).Value
DestSheet.Cells(dRow, "E").Formula = _
"=" & .Cells(sRow, lngSalaryColumn).Parent.Name & _
"!" & .Cells(sRow, lngSalaryColumn).Address(True, True)
End Select
End If
Next
End If

If lngHumptyCol > 0 Then
For sRow = 1 To lngLastRow
If .Cells(sRow, "B") Like "*Dept. Totals" Then
Select Case .Cells(sRow, lngHumptyCol).Value
Case 0
Case Is > 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = "humpty"
DestSheet.Cells(dRow, "D").Formula = _
"=" & .Cells(sRow, lngHumptyCol).Parent.Name & _
"!" & .Cells(sRow, lngHumptyCol).Address(True, True)
Case Is < 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = "humpty"
DestSheet.Cells(dRow, "E").Formula = _
"=" & .Cells(sRow, lngHumptyCol).Parent.Name & _
"!" & .Cells(sRow, lngHumptyCol).Address(True, True)
End Select
End If
Next
End If

If lngrecoverableCol > 0 Then
For sRow = 2 To lngLastRow
Select Case .Cells(sRow, lngrecoverableCol).Value
Case 0
Case Is > 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = "Recoverable"
DestSheet.Cells(dRow, "H").Value = .Cells(sRow, lngrecoverableCol + 1).Value
DestSheet.Cells(dRow, "D").Formula = _
"=" & .Cells(sRow, lngrecoverableCol).Parent.Name & _
"!" & .Cells(sRow, lngrecoverableCol).Address(True, True)
Case Is < 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = "Recoverable"
DestSheet.Cells(dRow, "H").Value = .Cells(sRow, lngrecoverableCol + 1).Value
DestSheet.Cells(dRow, "E").Formula = _
"=" & .Cells(sRow, lngrecoverableCol).Parent.Name & _
"!" & .Cells(sRow, lngrecoverableCol).Address(True, True)
End Select
Next
End If

If lngTestCol > 0 Then
For sRow = 1 To lngLastRow
If .Cells(sRow, "B") Like "*Dept. Totals" Then
Select Case .Cells(sRow, lngTestCol).Value
Case 0
Case Is > 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = "test"
DestSheet.Cells(dRow, "D").Formula = _
"=" & .Cells(sRow, lngTestCol).Parent.Name & _
"!" & .Cells(sRow, lngTestCol).Address(True, True)
Case Is < 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = "test"
DestSheet.Cells(dRow, "E").Formula = _
"=" & .Cells(sRow, lngTestCol).Parent.Name & _
"!" & .Cells(sRow, lngTestCol).Address(True, True)
End Select
End If
Next
End If
End With
End Sub

antonyjones1
04-19-2009, 10:54 AM
Hi Mark,

Once again that's perfect thanks very much!

What I was getting at with the number of Dim's I will be having wasn't whether there is a max number of variables or not but the fact that any macro will only allow you to have a moaximum number of lines in total (not sure how many it is). So if i'm having 90 variables i'm going to be running close to 1k lines of code if not more. I'm thinking this may take me to or over the limit?

mdmackillop
04-19-2009, 12:21 PM
Hi Antony.
You appear to be repeating code with changes only on the variables, in which case you should pass these variables to another sub containing the repeated code. Something like this (untested)

Dim _
DestSheet As Worksheet, _
SourceSheet As Worksheet, _
lngSalaryColumn As Long, _
lngHumptyCol As Long, _
lngTestCol As Long, _
lngLastRow As Long, _
lngrecoverableCol As Long, _
sRow As Long, _
dRow As Long

Sub CopyAndAssign()
dRow = 1

Set SourceSheet = ThisWorkbook.Worksheets("Sheet1")
Set DestSheet = ThisWorkbook.Worksheets("Sheet3")

With SourceSheet

lngLastRow = .Cells(Rows.Count, 2).End(xlUp).Row

On Error Resume Next
lngSalaryColumn = .Range("A1:Z1").Find("Salary", , , xlWhole).Column
lngHumptyCol = .Range("A1:Z1").Find("humpty", , , xlWhole).Column
lngTestCol = .Range("A1:Z1").Find("test", , , xlWhole).Column
lngrecoverableCol = .Range("A1:Z1").Find("Recoverable", , , xlWhole).Column
On Error GoTo 0

If lngSalaryColumn > 0 Then
Call DoStuff(lngSalaryColumn, "Salary")
End If

If lngHumptyCol > 0 Then
Call DoStuff(lngHumptyColumn, "Humpty")
End If

'Etc.

End With
End Sub

Sub DoStuff(MyCol As Long, Subject As String)
With SourceSheet
For sRow = 1 To lngLastRow
If .Cells(sRow, "B") Like "*Dept. Totals" Then
Select Case .Cells(sRow, MyCol).Value
Case 0
'// do nothing //
Case Is > 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = Subject
'DestSheet.Cells(dRow, "D").Value = .Cells(sRow, lngSalaryColumn).Value
DestSheet.Cells(dRow, "D").Formula = _
"=" & .Cells(sRow, MyCol).Parent.Name & _
"!" & .Cells(sRow, MyCol).Address(True, True)
Case Is < 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = Subject
'DestSheet.Cells(dRow, "E").Value = .Cells(sRow, lngSalaryColumn).Value
DestSheet.Cells(dRow, "E").Formula = _
"=" & .Cells(sRow, MyCol).Parent.Name & _
"!" & .Cells(sRow, MyCol).Address(True, True)
End Select
End If
Next
End With
End Sub

GTO
04-19-2009, 07:22 PM
Greetings Antony,

Malcom's suggestion is great and a good example of what I was referring to when mentioning that there will be logical places to break the code up at.

Now so far, the test(s) and results could be broken up into two different ones; those that test for "Dept. Totals" and end up planting three vals/formulas, and the section for the Recoverable column, which does not test for "Dept. Totals" but plants four vals/formulas (the fourth being the "Simpsons" names). BTW, a big "DOH!" on me, as I think I am finally understanding your alluding to the recoverable code...

Anyways, while I'm sure you'd easily adapt Malcom's improvements, as I think I am "getting" that there could be more "recoverable" areas, and mostly cuz I'd like to correct a "sin" I made early on, slobbering up a name.....

Please lets change:
lngSalaryColumn
To:
lngSalaryCol

That was just retarded on my part...

So presuming that you will be adding more "recoverable" areas/testing, maybe:

Option Explicit

Dim DestSheet As Worksheet
Dim SourceSheet As Worksheet
Dim lngSalaryCol As Long
Dim lngHumptyCol As Long
Dim lngTestCol As Long
Dim lngLastRow As Long
Dim lngRecoverableCol As Long
Dim sRow As Long
Dim dRow As Long

Sub CopyAndAssign_02()
dRow = 1

Set SourceSheet = ThisWorkbook.Worksheets("Sheet1")
Set DestSheet = ThisWorkbook.Worksheets("Sheet3")

With SourceSheet

lngLastRow = .Cells(Rows.Count, 2).End(xlUp).Row

On Error Resume Next
lngSalaryCol = .Range("A1:Z1").Find("Salary", , , xlWhole).Column
lngHumptyCol = .Range("A1:Z1").Find("humpty", , , xlWhole).Column
lngTestCol = .Range("A1:Z1").Find("test", , , xlWhole).Column
lngRecoverableCol = .Range("A1:Z1").Find("Recoverable", , , xlWhole).Column
On Error GoTo 0

If lngSalaryCol > 0 Then
Call DoStuff(lngSalaryCol, "Salary")
End If

If lngHumptyCol > 0 Then
Call DoStuff(lngHumptyCol, "Humpty")
End If

If lngRecoverableCol > 0 Then
Call DoOtherStuff(lngRecoverableCol, "Recoverable")
End If

If lngTestCol > 0 Then
Call DoStuff(lngTestCol, "Test")
End If
End With
End Sub

Sub DoStuff(MyCol As Long, Subject As String)
With SourceSheet
For sRow = 1 To lngLastRow
If .Cells(sRow, "B") Like "*Dept. Totals" Then
Select Case .Cells(sRow, MyCol).Value
Case 0
'// do nothing //
Case Is > 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = Subject
'DestSheet.Cells(dRow, "D").Value = .Cells(sRow, lngSalaryColumn).Value
DestSheet.Cells(dRow, "D").Formula = _
"=" & .Cells(sRow, MyCol).Parent.Name & _
"!" & .Cells(sRow, MyCol).Address(True, True)
Case Is < 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = Subject
'DestSheet.Cells(dRow, "E").Value = .Cells(sRow, lngSalaryColumn).Value
DestSheet.Cells(dRow, "E").Formula = _
"=" & .Cells(sRow, MyCol).Parent.Name & _
"!" & .Cells(sRow, MyCol).Address(True, True)
End Select
End If
Next
End With
End Sub

Sub DoOtherStuff(MyCol As Long, Subject As String)
With SourceSheet
For sRow = 2 To lngLastRow
Select Case .Cells(sRow, MyCol).Value
Case 0
Case Is > 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = Subject
DestSheet.Cells(dRow, "H").Value = .Cells(sRow, MyCol + 1).Value
DestSheet.Cells(dRow, "D").Formula = _
"=" & .Cells(sRow, MyCol).Parent.Name & _
"!" & .Cells(sRow, MyCol).Address(True, True)
Case Is < 0
dRow = dRow + 1
DestSheet.Cells(dRow, "C").Value = .Cells(sRow, "A").Value
DestSheet.Cells(dRow, "G").Value = Subject
DestSheet.Cells(dRow, "H").Value = .Cells(sRow, MyCol + 1).Value
DestSheet.Cells(dRow, "E").Formula = _
"=" & .Cells(sRow, MyCol).Parent.Name & _
"!" & .Cells(sRow, MyCol).Address(True, True)
End Select
Next
End With
End Sub


Hope this helps,

Mark

@MD: Thank you brother :bow: