This code works, but it's a seven minute ride.

1858 index numbers listed in column A.

In range C1 to EJ95 I need to find them and move them down 1 row and left 1 column. Each index number appears only once in this range.

Per usual, I struggle making array code work for me.

Thanks,
Howard


Sub ReDoData()
Dim c As Range, spNum As Range
Application.ScreenUpdating = False

With Range("C1:EJ950")
.UnMerge
End With

For Each c In Worksheets("Orginal List").Range("A1:A1858")

Set spNum = Sheets("Orginal List").Range("C1:EJ950") _
.Find(What:=c, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)

If Not spNum Is Nothing Then

spNum.Cut spNum.Offset(1, -1)

End If

Next

Application.ScreenUpdating = True
End Sub

Typo, EJ950

In range C1 to EJ95 I need to find them...

H

Hi Howard,

Am Sun, 29 Mar 2015 03:36:27 -0700 (PDT) schrieb L. Howard:

1858 index numbers listed in column A.

are the numbers in A1:A1858 unique?

In range C1 to EJ95 I need to find them and move them down 1 row and left 1 column. Each index number appears only once in this range.

Do all numbers from column A occur in C1:EJ950?


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional

Hi Howard,

Am Sun, 29 Mar 2015 03:36:27 -0700 (PDT) schrieb L. Howard:

This code works, but it's a seven minute ride.

I tried several ways. The fastest one was this way:

Sub ReDoData()
Dim varCheck As Variant, varTmp As Variant
Dim myDic As Object
Dim i As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set myDic = CreateObject("Scripting.Dictionary")

With Sheets("Orginal List")
.Range("C1:EJ950").UnMerge
.Range("XFD1").FormulaArray = _

"=IFERROR(ADDRESS(MIN(IF($C$1:$EJ$950=A1,ROW($1:$9 50))),MIN(IF($C$1:$EJ$950=A1,COLUMN(C:EJ)))),"""") "
.Range("XFD1").AutoFill Destination:=.Range("XFD1:XFD1858")
.Range("XFD1:XFD1858").Calculate

varTmp = .Range("XFD1:XFD1858")
.Columns("XFD").ClearContents

For i = 1 To UBound(varTmp)
myDic(varTmp(i, 1)) = varTmp(i, 1)
Next

varCheck = myDic.items

For i = 1 To UBound(varCheck)
If varCheck(i) < "" Then
.Range(varCheck(i)).Cut .Range(varCheck(i)).Offset(1, -1)
End If
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional

Hi Claus,

Thanks for taking the time to do the code.

Changed this

For i = 1 To UBound(varCheck)

To this

For i = 0 To UBound(varCheck)

It was missing the first index number.

Seems to work well.
Much faster than the loop of course.

The list in column A are unique values, and I believe they all occur in C1:HQ950. (a little range change, I was missing some data)


The worksheet of data is a horrible layout, although it makes sense to the user as it is a "map" of locations of equipment placed in a solar panel field. So the "blocks" of data on the sheet are in the same relation to each other as they are in the field, on the ground in real life.

Checking results is nearly impossible.

The further problem is transferring the data to a separate sheet to produce a more viewable and verifiable set of data.

The code puts the index number in the left most cell of a row of 22 serial numbers. With two different formats.

Some are like this:

1-1-1-2 x x x x x x x x x x x x x x x x x x x x x x

Some are like this:

1-1-1-3 x x x x x x x x x x x
x x x x x x x x x x x

So there are some index numbers followed by 22 serial numbers (23 cells)

And some index numbers followed by 11 serial numbers in two rows.

On Sheet New List is the goal to list like this.

1-1-1-1 x x x x x x x x x x x x x x x x x x x x x x
1-1-1-2 x x x x x x x x x x x x x x x x x x x x x x
1-1-1-3 x x x x x x x x x x x x x x x x x x x x x x
..
..
etc. for 1800+
..
..
4-14-5-5 x x x x x x x x x x x x x x x x x x x x x x
4-14-5-6 x x x x x x x x x x x x x x x x x x x x x x
4-14-5-7 x x x x x x x x x x x x x x x x x x x x x x

If they were all on a single row, I could do another loop to "find - resize -copy - xlEndUp(2)" to Sheet New List.

I can't figure out how to make a code know if it is working with a single 22 cell range or if it is a two row 12-x-11 cell range.

Howard

Changed this

For i = 1 To UBound(varCheck)

To this

For i = 0 To UBound(varCheck)

And now you're missing the last item...

For

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

Changed this

For i = 1 To UBound(varCheck)

To this

For i = 0 To UBound(varCheck)

And now you're missing the last item...

For

Ignore this...

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

Hi Howard,

Am Sun, 29 Mar 2015 15:28:47 -0700 (PDT) schrieb L. Howard:


For i = 1 To UBound(varCheck)

To this

For i = 0 To UBound(varCheck)

sorry, all other arrays had base 1. So I made this mistake.

The further problem is transferring the data to a separate sheet to produce a more viewable and verifiable set of data.

Do you want to cut matches and insert them offset(1,-1) and also
transfer the matches to a new sheet?
Or what data do you want to transfer? If all values from column A occure
in the range C1:HQ950 you could copy column A and paste only the values.
Then wraptext is false in the new list.
Are some cells merged in the range C1:HQ950? And in column A also?


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional

Do you want to cut matches and insert them offset(1,-1) and also
transfer the matches to a new sheet?
Or what data do you want to transfer? If all values from column A occure
in the range C1:HQ950 you could copy column A and paste only the values.
Then wraptext is false in the new list.
Are some cells merged in the range C1:HQ950? And in column A also?


Regards
Claus B.


Do you want to cut matches and insert them offset(1,-1) and also
transfer the matches to a new sheet?

That is exactly the aim. Probably should have said so to start with, but wasn't sure if I was even going to proceed with the first part.

Here is what I have so far, which seems to work for single row data, and the UNION part, I find does not copy two ranges, plus it is a loop which will take forever to run. But I thought I would give it a try.

Here is the transfer part I have, where the ElseIf part does not work.

If Not spNum Is Nothing Then
If spNum.Offset(1, 1) = "" Then
spNum.Resize(1, 23).Copy Sheets("New List").Range("A" & Rows.Count).End(xlUp)(2)

ElseIf spNum.Offset(1, 1) < "" Then

Set rng1 = spNum.Resize(1, 12)
Set rng2 = spNum.Offset(1, 1).Resize(1, 11)

Set rngUnion = Application.Union(rng1, rng2)
rngUnion.Copy Sheets("New List").Range("A" & Rows.Count).End(xlUp)(2)
End If
End If


Are some cells merged in the range C1:HQ950? And in column A also?

Many, many in the range, but not in column A. However the code you provided, dumps the merged cells.

I think I see what you are saying about the transfers. I'll study that some more.

Howard

Hi Howard,

Am Mon, 30 Mar 2015 08:50:29 -0700 (PDT) schrieb L. Howard:

Here is the transfer part I have, where the ElseIf part does not work.

try:

Sub ReDoData()
Dim varCheck As Variant, varTmp As Variant
Dim myDic As Object
Dim rngBig As Range, rngTmp As Range
Dim i As Long, n As Long
Dim st As Double

st = Timer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set myDic = CreateObject("Scripting.Dictionary")

With Sheets("Orginal List")
.Activate
.Range("A1:HQ1858").Replace what:=Chr(10), replacement:="",
lookat:=xlPart
.Range("A1:HQ1858").Select
With Selection
.WrapText = False
.MergeCells = False
End With

.Range("XFD1").FormulaArray = _

"=IFERROR(ADDRESS(MIN(IF($C$1:$HQ$950=A1,ROW($1:$9 50))),MIN(IF($C$1:$HQ$950=A1,COLUMN(C:HQ)))),"""") "
.Range("XFD1").AutoFill Destination:=.Range("XFD1:XFD1858")
.Range("XFD1:XFD1858").Calculate

varTmp = .Range("XFD1:XFD1858")
.Columns("XFD").ClearContents

For i = 1 To UBound(varTmp)
myDic(varTmp(i, 1)) = varTmp(i, 1)
Next

varCheck = myDic.items

For i = 0 To UBound(varCheck)
If varCheck(i) < "" Then
If Len(.Range(varCheck(i)).Offset(1, 1)) = 0 Then
Sheets("New List").Cells(Rows.Count, 1).End(xlUp)(2) _
.Resize(, 23).Value = .Range(varCheck(i)).Offset(,
1).Resize(, 23).Value
Else
Sheets("New List").Cells(Rows.Count, 1).End(xlUp)(2) _
.Resize(, 12).Value = .Range(varCheck(i)).Resize(,
12).Value
End If
.Range(varCheck(i)).Cut .Range(varCheck(i)).Offset(1, -1)
End If
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox Format(Timer - st, "0.000")
End Sub

Or :

Sub ReDoData2()
Dim varCheck As Variant
Dim Tmp, c
Dim i As Long
Dim st As Double

st = Timer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With Sheets("Orginal List")
.Activate
.Range("A1:HQ1858").Replace what:=Chr(10), replacement:="",
lookat:=xlPart
.Range("A1:HQ1858").Select
With Selection
.WrapText = False
.MergeCells = False
End With

varCheck = .Range("A1:A1858")

For i = 1 To UBound(varCheck)
Tmp = varCheck(i, 1)
c = Evaluate("=ADDRESS(MIN(IF($C$1:$HQ$950=" & Tmp _
& ",ROW($1:$950))),MIN(IF($C$1:$HQ$950=" & Tmp &
",COLUMN(C:HQ))))")
If Not IsError(c) Then
If Len(Range(c)) = 0 Then
Sheets("New List").Cells(Rows.Count, 1).End(xlUp)(2) _
.Resize(, 23).Value = Range(c).Offset(, 1).Resize(,
23).Value
Else
Sheets("New List").Cells(Rows.Count, 1).End(xlUp)(2) _
.Resize(, 12).Value = Range(c).Resize(, 12).Value
End If
.Range(c).Cut .Range(c).Offset(1, -1)
End If
Next
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox Format(Timer - st, "0.000")
End Sub


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional