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

Wow, thanks Claus.

I ran Sub ReDoData() and it moved the index numbers to left of the serial numbers, but did not transfer to New List sheet. (Timer did not work, as I saw no message box)

Ran the Sub ReDoData2() and it worked fine, as near as I can tell. Data looks fine on New List sheet, but did not return 1858 entries. I suspect this is due to "errors" on the Orginal List sheet data field. I found some duplicate index numbers within the field, so that looks like a "user must fix" problem. And I would guess there are some index numbers in column A that do not exist in the field. Timer did not work on this code either, as I saw no message box here also. A time is not necessary, we know it has a lot of work to do and will take a few minutes.)

Appreciate the code, it does sorta tames down a really wildly laid out worksheet.

Howard

Hi Howard,

Am Mon, 30 Mar 2015 16:07:32 -0700 (PDT) schrieb L. Howard:

I ran Sub ReDoData() and it moved the index numbers to left of the serial numbers, but did not transfer to New List sheet. (Timer did not work, as I saw no message box)

on my machine ReDoData is faster than ReDoData2 and it works absolutely
correct. All matches will be written to New List.


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

On Monday, March 30, 2015 at 10:43:55 PM UTC-7, Claus Busch wrote:
Hi Howard,

Am Mon, 30 Mar 2015 16:07:32 -0700 (PDT) schrieb L. Howard:

I ran Sub ReDoData() and it moved the index numbers to left of the serial numbers, but did not transfer to New List sheet. (Timer did not work, as I saw no message box)

on my machine ReDoData is faster than ReDoData2 and it works absolutely
correct. All matches will be written to New List.


Regards
Claus B.
--

I was sure it was good code, not sure why it does not play nice with me.

I will try some more to see if I can make it work on my end.

Thanks, Howard

Hi Claus,

Would you mind taking a look at this workbook.

https://www.dropbox.com/s/3qdiiqqwip...%201.xlsm?dl=0

The ReDoData (slightly renamed in the workbook) Almost works, but is not making a full and clean transfer to New list sheet.

I did get the msgbox time notification in this new workbook.

Howard

Hi Howard,

Am Tue, 31 Mar 2015 05:15:51 -0700 (PDT) schrieb L. Howard:

https://www.dropbox.com/s/3qdiiqqwip...%201.xlsm?dl=0

now that I saw your workbook I could check the data. The values in
column A are unique and so are the found cell addresses in XFD.
I revised the code because you don't need varTmp and the Dictionary.
So I checked carefully I could not find out why 3 values are missing.
You have 1857 items in column A and also 1857 addresses but in New List
there are only 1854 rows filled.
Have a look:
https://onedrive.live.com/?cid=9378A...121822A3%21326
for your workbook.


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

Hi Claus,

Would you mind taking a look at this workbook.

https://www.dropbox.com/s/3qdiiqqwip...%201.xlsm?dl=0

The ReDoData (slightly renamed in the workbook) Almost works, but is
not making a full and clean transfer to New list sheet.

I did get the msgbox time notification in this new workbook.

Howard

I have to ask...

How did this data get into the worksheet in this layout state in the
1st place?

...reason being this is definitely not how we log solar panel serials on
our installations/farms!

--
Garry

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

Just curious why you presume user has automatic Calculation...

Dim lCalcMode&

With Application
lCalcMode = .Calculation: .Calculation = xlCalculationManual
'...
End With

'...code

With Application
.Calculation = lCalcMode
'...
End With

...when it's easy to preserve/restore user setting!

Another issue is when more than one procedure is coded to toggle common
settings. I use a central handler routine that ensures only one process
has control...


'--------------------------------------------------------------------------------------
' **Note: EnableFastCode requires the following declarations be in a
standard module.
'--------------------------------------------------------------------------------------
'Type udtAppModes
' 'Default types
' Events As Boolean: CalcMode As XlCalculation: Display As Boolean:
CallerID As String
' 'Project-specific types
'End Type
'Public AppMode As udtAppModes
'--------------------------------------------------------------------------------------
Sub EnableFastCode(Caller$, Optional SetFast As Boolean = True)
' **Note: Requires 'Type udtAppModes' and 'Public AppMode As
udtAppModes' declarations

'The following will make sure only the Caller has control,
'and allows any Caller to take control when not in use.
If AppMode.CallerID < Caller Then _
If AppMode.CallerID < "" Then Exit Sub

With Application
If SetFast Then
AppMode.Display = .ScreenUpdating: .ScreenUpdating = False
AppMode.CalcMode = .Calculation: .Calculation =
xlCalculationManual
AppMode.Events = .EnableEvents: .EnableEvents = False
AppMode.CallerID = Caller
Else
.ScreenUpdating = AppMode.Display
.Calculation = AppMode.CalcMode
.EnableEvents = AppMode.Events
AppMode.CallerID = ""
End If
End With
End Sub

...where Caller is defined in the process controlling these settings
like so...

Sub MyAction()
Const sSource$ = "MyAction"

EnableFastCode sSource
'...code

EnableFastCode sSource, False
End Sub

...so if the above routine calls other procedures that also toggle these
settings, they can't interfere with the original caller's control. The
other procedures may be used independantly and so may need to toggle
settings if not already 'in play' by some other proc.!

--
Garry

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