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?
Attachment 554
Which data is supposed to be copied, Sheet1? Sheet3 already has data in column D.
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
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.
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.
[vba]
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[/vba]
Hope this helps,
Mark
Last edited by GTO; 04-04-2009 at 05:50 PM.
Hi Mark,Originally Posted by GTO
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?
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
[vba]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[/vba]
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.Attachment 564
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:
[vba] 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
[/vba]
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
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!
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.
[vba]
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
[/vba]
Hope that helps,
Mark
Perfect Mark. Thanks again for all your help!
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?
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...
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
Hi Mark,
Just had another play with it and actually did manage to get the new bit of code working.
[vba]
If lngRecoverableCol > 0 Then[/vba]
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 [vba]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 [/vba]
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!Attachment 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!
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
[vba]
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
[/vba]
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?
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)
[vba]
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
[/vba]
MVP (Excel 2008-2010)
Post a workbook with sample data and layout if you want a quicker solution.
To help indent your macros try Smart Indent
Please remember to mark threads 'Solved'
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:
[vba]
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
[/vba]
Hope this helps,
Mark
@MD: Thank you brother
Posting Permissions
Reply With Quote
