J
justagrunt
Sorry for the title and the code attached,
Basically I have reached that stretch where I do not have enough skill or
experience to get a program to work.
Two sheets.
The row on sheet (3) must increase with each loop.
The row on sheet (2) checks for a match in value with sheet (3)
If found the 3 cells on sheet (3) are copied and pasted into sheet (2).
The row on sheet (2) increases as the row in sheet (3) does at the next loop.
The loop keeps going until the last row that may have information is reached
on sheet(3).
Dim i As Integer 'horizontal row step count
Dim j As Integer 'tracking sheet move down one
Dim k As Integer 'summary sheet move down one row after saving pasted info.
'Match the code on row4 (Sheet 3) Range Horizontal (A4 : HQ4)
'with the code on trackingsheet (Sheet2) Vertical Range (A59 : A209)
'when they match, then take the offset Horizontal range value and copy it to
the
'correct horizontal cells vertically offset in the Range on summary
'drop down a row for pasting too for next loop for value in sheet (2)
'loop until finished.
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim rng4 As Range
Dim rng5 As Range
Dim rng6 As Range
Dim rng7 As Range
Dim rng8 As Range
Dim rng9 As Range
Dim rng10 As Range
Dim rng11 As Range
Dim cell As Range
Dim res As Variant
Dim z As Variant
'sheet 2 tracking sheet
'set up counter and limits
j = 58
Sheet2.Visible = True
Do
Set rng2 = Sheet2.Range(Cells(j, 1)) 'row and column
'set up the search
For Each cell In rng1
'sheet 3 is where rng1 is found
Sheet3.Visible = True 'summary sheet(3)
k = 55 'starting row for copying too,
on summary sheet
Set rng1 = Sheet3.Range("A4:HQ4") 'row and column
res = "" 'res = some string on sheet(2)
in column 1
res = Application.WorksheetFunction.Match(cell.Value, rng2, 0) ' match
string on sheet 2 with something on sht 3
If Not IsError(res) Then ' they match
' do something like start copying cell information
z = "" 'basically z = res
z = cell.Value 'set object from Match function
Rem MsgBox cell.Value ' placed for debugging when it works to
this line
'copy cells from tracking sheet2 , there are 3 cells
Sheet2.Visible = True
Set rng3 = Sheet2.Range("A4:HQ4").Find(what:=z,
LookIn:=xlValues) 'find the value in sht2 which is res
Set rng4 = rng3.Offset(0, 17) '0 cells (row)down 17 cells
(column) across is the offset to column Q
Set rng5 = rng3.Offset(0, 22) '0 cells (row)down 22 cells
(column) across is the offset to column V
Set rng6 = rng3.Offset(0, 21) '0 cells (row)down 21 cells
(column) across is the offset to column U
'paste into summary sht3
Set rng7 = Sheets("table").Range(Cells(4, i)).Find(what:=z,
LookIn:=xlValues) 'find the correct cell
Set rng8 = rng7.Offset(k, 0) ' "k" cells down (row) 0
cells across (column) is the offset
rng4.Copy Destination:=Sheet3.Range(rng8.Address) 'copy
the value Q
rng9 = rng8.Offset(0, 5)
rng5.Copy: Sheet3.Range(rng9.Address).PasteSpecial 'copy
the value V
rng10 = rng8.Offset(0, 4)
rng6.Copy: Sheet3.Range(rng10.Address).PasteSpecial 'copy
the value U
k = k + 1 'paste completed, go down one row for next
cycle
Else
' they don't match
End If
' continue
Next
Loop Until j = 209 ' next row down for sheet 3 tracking
Any suggestions where I'm going wrong???? or push shove , kick, in the right
direction.
If I can get this to work an xls sheet of 11meg with if and do's in each
cell will be ruduced to say 353K before information is pasted to sheet(3) for
the thing to work.
Hope springs eternal - it is Xmas. Thanks in advance for your assistance.
Basically I have reached that stretch where I do not have enough skill or
experience to get a program to work.
Two sheets.
The row on sheet (3) must increase with each loop.
The row on sheet (2) checks for a match in value with sheet (3)
If found the 3 cells on sheet (3) are copied and pasted into sheet (2).
The row on sheet (2) increases as the row in sheet (3) does at the next loop.
The loop keeps going until the last row that may have information is reached
on sheet(3).
Dim i As Integer 'horizontal row step count
Dim j As Integer 'tracking sheet move down one
Dim k As Integer 'summary sheet move down one row after saving pasted info.
'Match the code on row4 (Sheet 3) Range Horizontal (A4 : HQ4)
'with the code on trackingsheet (Sheet2) Vertical Range (A59 : A209)
'when they match, then take the offset Horizontal range value and copy it to
the
'correct horizontal cells vertically offset in the Range on summary
'drop down a row for pasting too for next loop for value in sheet (2)
'loop until finished.
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim rng4 As Range
Dim rng5 As Range
Dim rng6 As Range
Dim rng7 As Range
Dim rng8 As Range
Dim rng9 As Range
Dim rng10 As Range
Dim rng11 As Range
Dim cell As Range
Dim res As Variant
Dim z As Variant
'sheet 2 tracking sheet
'set up counter and limits
j = 58
Sheet2.Visible = True
Do
Set rng2 = Sheet2.Range(Cells(j, 1)) 'row and column
'set up the search
For Each cell In rng1
'sheet 3 is where rng1 is found
Sheet3.Visible = True 'summary sheet(3)
k = 55 'starting row for copying too,
on summary sheet
Set rng1 = Sheet3.Range("A4:HQ4") 'row and column
res = "" 'res = some string on sheet(2)
in column 1
res = Application.WorksheetFunction.Match(cell.Value, rng2, 0) ' match
string on sheet 2 with something on sht 3
If Not IsError(res) Then ' they match
' do something like start copying cell information
z = "" 'basically z = res
z = cell.Value 'set object from Match function
Rem MsgBox cell.Value ' placed for debugging when it works to
this line
'copy cells from tracking sheet2 , there are 3 cells
Sheet2.Visible = True
Set rng3 = Sheet2.Range("A4:HQ4").Find(what:=z,
LookIn:=xlValues) 'find the value in sht2 which is res
Set rng4 = rng3.Offset(0, 17) '0 cells (row)down 17 cells
(column) across is the offset to column Q
Set rng5 = rng3.Offset(0, 22) '0 cells (row)down 22 cells
(column) across is the offset to column V
Set rng6 = rng3.Offset(0, 21) '0 cells (row)down 21 cells
(column) across is the offset to column U
'paste into summary sht3
Set rng7 = Sheets("table").Range(Cells(4, i)).Find(what:=z,
LookIn:=xlValues) 'find the correct cell
Set rng8 = rng7.Offset(k, 0) ' "k" cells down (row) 0
cells across (column) is the offset
rng4.Copy Destination:=Sheet3.Range(rng8.Address) 'copy
the value Q
rng9 = rng8.Offset(0, 5)
rng5.Copy: Sheet3.Range(rng9.Address).PasteSpecial 'copy
the value V
rng10 = rng8.Offset(0, 4)
rng6.Copy: Sheet3.Range(rng10.Address).PasteSpecial 'copy
the value U
k = k + 1 'paste completed, go down one row for next
cycle
Else
' they don't match
End If
' continue
Next
Loop Until j = 209 ' next row down for sheet 3 tracking
Any suggestions where I'm going wrong???? or push shove , kick, in the right
direction.
If I can get this to work an xls sheet of 11meg with if and do's in each
cell will be ruduced to say 353K before information is pasted to sheet(3) for
the thing to work.
Hope springs eternal - it is Xmas. Thanks in advance for your assistance.