PC Review


Reply
Thread Tools Rate Thread

How to alter the code to copy to the same exact cell destination?

 
 
Adnan
Guest
Posts: n/a
 
      6th Aug 2008
Hi all,

I do not quite understand this. When this code runs, it copies values and
formulas from one workbook to another. The issue is that some of the rows in
source workbook are hidden and what this codes does copies but not to the
same cell in the destination workbook.

i.e:
Source Workbook
A B
1 Text1 10
2 Text2 [has a formula C2+E2]
3 [this row is blank therefore hidden]
4 Text3 [has a formula C4+E4]

Destination Workbook
A B
1 Text1 10
2 Text2 [has a formula C2+E2]
4 Text3 [has a formula C4+E4] <----------- this is the issue I am
referring to. It should have been C3+C3
3 [this row is blank therefore hidden]

So, what do I need to alter in following code to remove this error?


Sub Data_Sheet(PE As Workbook, Template As Workbook)

Dim PEStartRow As Long
Dim TemplateAddress As Range
Dim PC As Long
Dim Dell As Long
Dim i, s, l, p, d, sr, w, b As Long
Dim EWRow As Range
Dim PERow As Range


s = 44
p = 40
sr = 204

Application.Calculation = xlCalculationManual

PEStartRow = Empty
PE.Worksheets("Sheet1").Activate

For i = 8 To 15
If Cells(i, 1).Value Like "*Site*" Then
PEStartRow = i + 1
Exit For
End If
Next i

Template.Worksheets("Sheet1").Cells(12, 1).Value =
PE.Worksheets("Sheet1").Cells(PEStartRow, 1).Value

For n = PEStartRow + 10 To 280
If Cells(n, 6).Value = "" And Cells(n + 1, 1).Value <> "" Then
Template.Worksheets("Sheet1").Cells(s, 1).Value =
PE.Worksheets("Sheet1").Cells(n + 1, 1).Value
s = s + 32
End If
Next n


For l = 12 To 300
d = p + 2

If PE.Worksheets("Sheet1").Cells(l, 6).Value Like "*PC MODEL
DEVICE*" Then
PC = Cells(l, 3).Value
Template.Worksheets("Sheet1").Cells(p, 3).Value = PC
ElseIf PE.Worksheets("Sheet1").Cells(l, 6).Value Like "*DELL
POWEREDGE*" Then
Dell = Cells(l, 3).Value
Template.Worksheets("Sheet1").Cells(d, 3).Value = Dell
p = p + 32
End If
Next l

For w = 12 To 300
Set EWRow = Template.Worksheets("Sheet1").Cells(sr, 1)
If PE.Worksheets("Sheet1").Rows(w).EntireRow.Hidden = False
Then

If Cells(w, 2).Value <> "11" And Cells(w, 2).Value <> "12"
And Cells(w, 2).Value <> "13" And Cells(w, 2).Value <> "37" Then
Set PERow = PE.Worksheets("Sheet1").Cells(w, 1)
For b = 0 To 20
EWRow.Offset(0, b).Value = PERow.Offset(0,
b).Value
EWRow.Offset(0, b).Formula = PERow.Offset(0,
b).Formula
Next b
End If

sr = sr + 1
End If
Next w

Set PEETCCell = PE.Worksheets("Sheet1").Cells(2, 22)
Set TemplateETCCell = Template.Worksheets("Sheet1").Cells(2, 22)

For m = 0 To 5
TemplateETCCell.Offset(m, 0).Value =
PEETCCell.Offset(m, 0).Value
Next m

End Sub

Translatting it as what it does would also be a great help.

I appreciate any help provided,
Adnan
 
Reply With Quote
 
 
 
 
Adnan
Guest
Posts: n/a
 
      7th Aug 2008
Anyone any suggestion?


"Adnan" wrote:

> Hi all,
>
> I do not quite understand this. When this code runs, it copies values and
> formulas from one workbook to another. The issue is that some of the rows in
> source workbook are hidden and what this codes does copies but not to the
> same cell in the destination workbook.
>
> i.e:
> Source Workbook
> A B
> 1 Text1 10
> 2 Text2 [has a formula C2+E2]
> 3 [this row is blank therefore hidden]
> 4 Text3 [has a formula C4+E4]
>
> Destination Workbook
> A B
> 1 Text1 10
> 2 Text2 [has a formula C2+E2]
> 4 Text3 [has a formula C4+E4] <----------- this is the issue I am
> referring to. It should have been C3+C3
> 3 [this row is blank therefore hidden]
>
> So, what do I need to alter in following code to remove this error?
>
>
> Sub Data_Sheet(PE As Workbook, Template As Workbook)
>
> Dim PEStartRow As Long
> Dim TemplateAddress As Range
> Dim PC As Long
> Dim Dell As Long
> Dim i, s, l, p, d, sr, w, b As Long
> Dim EWRow As Range
> Dim PERow As Range
>
>
> s = 44
> p = 40
> sr = 204
>
> Application.Calculation = xlCalculationManual
>
> PEStartRow = Empty
> PE.Worksheets("Sheet1").Activate
>
> For i = 8 To 15
> If Cells(i, 1).Value Like "*Site*" Then
> PEStartRow = i + 1
> Exit For
> End If
> Next i
>
> Template.Worksheets("Sheet1").Cells(12, 1).Value =
> PE.Worksheets("Sheet1").Cells(PEStartRow, 1).Value
>
> For n = PEStartRow + 10 To 280
> If Cells(n, 6).Value = "" And Cells(n + 1, 1).Value <> "" Then
> Template.Worksheets("Sheet1").Cells(s, 1).Value =
> PE.Worksheets("Sheet1").Cells(n + 1, 1).Value
> s = s + 32
> End If
> Next n
>
>
> For l = 12 To 300
> d = p + 2
>
> If PE.Worksheets("Sheet1").Cells(l, 6).Value Like "*PC MODEL
> DEVICE*" Then
> PC = Cells(l, 3).Value
> Template.Worksheets("Sheet1").Cells(p, 3).Value = PC
> ElseIf PE.Worksheets("Sheet1").Cells(l, 6).Value Like "*DELL
> POWEREDGE*" Then
> Dell = Cells(l, 3).Value
> Template.Worksheets("Sheet1").Cells(d, 3).Value = Dell
> p = p + 32
> End If
> Next l
>
> For w = 12 To 300
> Set EWRow = Template.Worksheets("Sheet1").Cells(sr, 1)
> If PE.Worksheets("Sheet1").Rows(w).EntireRow.Hidden = False
> Then
>
> If Cells(w, 2).Value <> "11" And Cells(w, 2).Value <> "12"
> And Cells(w, 2).Value <> "13" And Cells(w, 2).Value <> "37" Then
> Set PERow = PE.Worksheets("Sheet1").Cells(w, 1)
> For b = 0 To 20
> EWRow.Offset(0, b).Value = PERow.Offset(0,
> b).Value
> EWRow.Offset(0, b).Formula = PERow.Offset(0,
> b).Formula
> Next b
> End If
>
> sr = sr + 1
> End If
> Next w
>
> Set PEETCCell = PE.Worksheets("Sheet1").Cells(2, 22)
> Set TemplateETCCell = Template.Worksheets("Sheet1").Cells(2, 22)
>
> For m = 0 To 5
> TemplateETCCell.Offset(m, 0).Value =
> PEETCCell.Offset(m, 0).Value
> Next m
>
> End Sub
>
> Translatting it as what it does would also be a great help.
>
> I appreciate any help provided,
> Adnan

 
Reply With Quote
Reply

Thread Tools
Rate This Thread
Rate This Thread:

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are Off


Similar Threads
Thread Thread Starter Forum Replies Last Post
Code to Alter value by adding 1 to value in cell 4 rows above Corey Microsoft Excel Programming 5 28th Nov 2006 03:34 AM
Copy every 3rd cell, define destination range for paste =?Utf-8?B?TWVsdGFk?= Microsoft Excel Programming 1 27th Sep 2006 01:46 PM
Copy exact value from one cell to new formula in another cell =?Utf-8?B?YXNnMjMwNw==?= Microsoft Excel Misc 2 6th Feb 2006 09:33 PM
Copy Destination:= Code Stops Here =?Utf-8?B?Um9iZXJ0IENocmlzdGll?= Microsoft Excel Programming 4 27th Jan 2005 12:15 AM
Copy an exact cell value (text) Rasmus Microsoft Excel Programming 1 12th Sep 2004 12:15 PM


Features
 

Advertising
 

Newsgroups
 


All times are GMT +1. The time now is 08:02 AM.