PDA

View Full Version : loop + offset/resize problem



choubix
06-22-2008, 10:54 AM
hello,

I was trying to do something not using a loop. Xld was kind enough to give me a code but it will take me some time to understand :( (thanks xld, I am going to take some time to go through the code to understand it)

Since I need to fix my spreadsheet Asap I came up with this dirty fix (using a loop...)



Sub Skip_Blanks_Simple()
Dim cCount As Variant
Dim i As Integer, j As Integer
cCount = Evaluate("SUMPRODUCT((Len(C1:C65000) > 0) * 1)")
For i = 1 To 88 'wsOutput.Range("B65536").End(xlUp).Count 88 wsOutput.Range(Cells(65535, 2)).End(xlUp).count
If Not IsEmpty(wsOutput.Cells(i, 3)) Then
For j = 1 To cCount
wsOutput.Cells(j, 6).Offset(, 1).Resize(, 2) = "= " & wsOutput.Cells(i, 3).Offset(, -1).Resize(, 2).Address & ""
'wsOutput.Cells(j, 5) = "=" & wsOutput.Cells(i, 2).Address & ""
'wsOutput.Cells(j, 6) = "=" & wsOutput.Cells(i, 3).Address & ""
Next
End If
Next

the idea is: I have a set of data in column B.
I use a loop in column B.
if for any value in column B their is a value in column C
in column E and F: copy the address of B an C (so output should be "=B22" and =C22) for instance)

right now I have 3 problems:

- in the 1st loop: I dont point correctly to the last cell in the range (so I had to hardcode the last cell for the sake of the example
- 2nd: the values returned are not correct using offset and resize
- 3rd: if I use the code that is turned off (
'wsOutput.Cells(j, 5) = "=" & wsOutput.Cells(i, 2).Address & ""
'wsOutput.Cells(j, 6) = "=" & wsOutput.Cells(i, 3).Address & "") it shows the correct data BUT it shows only the last data set (so the loop is not correct)

any idea what is wrong here please? (appart from the coder I currently am ;) )

thanks!

Bob Phillips
06-22-2008, 11:17 AM
Which previous thread are you referring to, I am struggling to understand what you are doing here.

choubix
06-22-2008, 11:23 AM
hi, this one:

http://www.vbaexpress.com/forum/showthread.php?t=20335

what i need:
loop column B,
if there is a value in column C,
copy the address of both B and C in E1 and F1,
continue looping in B, next time there is a value in C, copy the address of B and C in E2, F2
etcetc

For instance
in E1 I should have =B22 and in F1 I should have =C22
in E2, I should have =B38 and in F2 I should have =C38
in E3 I should have =B40 and F3 I should have =C40

etcetc

Bob Phillips
06-22-2008, 04:02 PM
Sub CopyData()
Dim rng As Range
Dim LastRow As Long
Dim DataSet As String
Dim Data As Variant
Dim Addresses As Variant
Dim i As Long, j As Long, k As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
On Error Resume Next
Set rng = Range("A1").Resize(LastRow, 2)
On Error GoTo 0
If Not rng Is Nothing Then
DataSet = NotUnion(rng, rng.SpecialCells(xlCellTypeBlanks))
End If
Data = Split(DataSet, ",")
For i = LBound(Data) To UBound(Data)
Addresses = Split(Replace(Data(i), ":", ""), "$")
For j = Addresses(LBound(Addresses) + 2) To Addresses(LBound(Addresses) + 4)
k = k + 1
.Cells(k, "E").Value = .Cells(j, "A").Address
.Cells(k, "F").Value = .Cells(j, "B").Address
Next j
Next i
End With
End Sub


'-----------------------------------------------------------------
Function NotUnion(SetRange As Range, UsedRange As Range, _
Optional RowAbsolute As Boolean = True, _
Optional ColumnAbsolute As Boolean = True, _
Optional ReferenceStyle As XlReferenceStyle = xlA1, _
Optional External As Boolean = False) As String
'-----------------------------------------------------------------
Dim saveSet
Dim rng As Range
saveSet = SetRange.Formula
SetRange.ClearContents
UsedRange = 0
Set rng = SetRange.SpecialCells(xlCellTypeBlanks)
NotUnion = rng.Address(RowAbsolute, ColumnAbsolute, ReferenceStyle, External)
SetRange = saveSet
End Function

mikerickson
06-22-2008, 11:12 PM
...
if there is a value in column C,
copy the address of both B and C in E1 and F1,
continue looping in B, next time there is a value in C, copy the address of B and C in E2, F2
etcetc

For instance
in E1 I should have =B22 and in F1 I should have =C22
in E2, I should have =B38 and in F2 I should have =C38
in E3 I should have =B40 and F3 I should have =C40
I think this will do that.

Sub test()
On Error Resume Next
With ThisWorkbook.Sheets("sheet1").Range("c:c")
With Range(.Cells(1, 1), .Cells(.Rows.Count).End(xlUp))
.Offset(0, 2).Resize(, 2).ClearContents
Application.Intersect(.SpecialCells(xlCellTypeConstants).EntireRow, .Parent.Range("E:F")).FormulaR1C1 = "=RC[-3]"
Application.Intersect(.SpecialCells(xlCellTypeFormulas).EntireRow, .Parent.Range("E:F")).FormulaR1C1 = "=RC[-3]"
.Offset(0, 2).Resize(, 2).SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
End With
End With
On Error GoTo 0
End Sub