# Copy individual range based on highlighted last cell from sheet to another



## KalilMe (Sunday at 4:04 AM)

Hello
I  want  copying   for  each  range  just  contains  higlighted  cell   in column H for  the  last  row (SUMMING) from sheet to another 
source data
Copy of TR.xlsmABCDEFGH1CODE2FR-003ITEMDATEGOODSTYPEPRQTYUNITTOTAL4101/01/2021BANANAFOPL200.0012.002400.005207/01/2021BANANAFOPL450.0012.005400.006308/01/2021BANANAFOPL500.0019.579785.717414/01/2021BANANAFOPL800.0025.3620285.718515/01/2021BANANAFOPL850.0026.3222373.219SUMMING2800.0060244.64101112CODE13FR-0114ITEMDATEGOODSTYPEPRQTYUNITTOTAL15102/01/2021APPLEFRPPL100.0014.001400.0016209/01/2021APPLEFRPPL550.0020.5411294.6417316/01/2021APPLEFRPPL900.0027.2924557.1418SUMMING1550.0037251.79192021CODE22FR-0223ITEMDATEGOODSTYPEPRQTYUNITTOTAL24103/01/2021PEACHFRLLP300.0015.004500.0025210/01/2021PEACHFRLLP600.0021.5012900.0026317/01/2021PEACHFRLLP950.0028.2526837.5027SUMMING1850.0044237.50282930CODE31FR-0332ITEMDATEGOODSTYPEPRQTYUNITTOTAL33104/01/2021PEARFRTTL300.0012.003600.0034211/01/2021PEARFRTTL650.0022.4614601.7935318/01/2021BANANAFOPL1000.0029.2129214.2936SUMMING1950.0047416.07373839CODE40FR-0441ITEMDATEGOODSTYPEPRQTYUNITTOTAL42105/01/2021STRWBERRAYFRMML350.0020.007000.0043212/01/2021STRWBERRAYFRMML700.0023.4316400.0044319/01/2021APPLEFRPPL1050.0030.1831687.5045SUMMING2100.0055087.50RETSEL

result  like  this 
Copy of TR.xlsmABCDEFGH1CODE2FR-003ITEMDATEGOODSTYPEPRQTYUNITTOTAL4101/01/2021BANANAFOPL200.0012.002400.005207/01/2021BANANAFOPL450.0012.005400.006308/01/2021BANANAFOPL500.0019.579785.717414/01/2021BANANAFOPL800.0025.3620285.718515/01/2021BANANAFOPL850.0026.3222373.219SUMMING2800.0060244.64101112CODE13FR-0214ITEMDATEGOODSTYPEPRQTYUNITTOTAL15103/01/2021PEACHFRLLP300.0015.004500.0016210/01/2021PEACHFRLLP600.0021.5012900.0017317/01/2021PEACHFRLLP950.0028.2526837.5018SUMMING1850.0044237.50192021CODE22FR-0423ITEMDATEGOODSTYPEPRQTYUNITTOTAL24105/01/2021STRWBERRAYFRMML350.0020.007000.0025212/01/2021STRWBERRAYFRMML700.0023.4316400.0026319/01/2021APPLEFRPPL1050.0030.1831687.5027SUMMING2100.0055087.50result

*note: *the data are increasable and changeable in sheet RETSEL


----------



## shinigamilight (Sunday at 6:16 AM)

```
Sub dream()
        Dim lr As Long
        Dim Coloring As Long
        Dim wk1, wk2 As Worksheet
        Set wk1 = Sheets("Project1") 'this is the input sheet
        Set wk2 = Sheets("Project2") ' this is the output sheet aka result sheet
        Dim k As Integer
       
        ' make sure input sheet is selected at the time of running the code very important
       
        lr = Cells.Find("*", Cells(1, 1), xlFormulas, xlWhole, xlByRows, xlPrevious, False).Row
        Coloring = 52377 'this is the color of your highlighted cell you can change it to your liking
       
        For k = 1 To lr
                If wk1.Range("H" & k).Interior.Color = Coloring Then
                    wk1.Range("H" & k).CurrentRegion.Copy _
                        wk2.Range("A" & Rows.Count).End(xlUp).Offset(4, 0)
                End If
        Next k
       
        wk2.Range("A1:A4").EntireRow.Delete shift:=xlUp
       
       

       
End Sub
```


----------



## shinigamilight (Sunday at 6:20 AM)

```
Sub dream2()
        ' this how your find the color of a cell
        
        MsgBox Range("H9").Interior.Color
        
End Sub
```


----------



## KalilMe (Sunday at 7:20 AM)

thanks  but  seem  slow  when  I  have  data 8000 rows . it  takes  more  time  .
do  you  have  a way  to  make  faster  ,please?


----------



## HaHoBe (Sunday at 8:33 AM)

Hi KalilMe,

what about


```
Public Sub MrE_1226327_1700811()
' https://www.mrexcel.com/board/threads/copy-individual-range-based-on-highlighted-last-cell-from-sheet-to-another.1226327/

'Assumptions: Code-Nr to transfer to is located on Column E in the second row of the area to work on
'             "SUMMING" is in capital letter and located on Column B in the last row of the area to work on
'             ColorIndex for highlighting is vbYellow or 6
'             Value to transfer is located on Column H in the last row of the area to work on

'/// Please note: ALWAYS run the macros on a copy of your Workbook !!!!

Dim wsTarg As Worksheet
Dim wsData As Worksheet
Dim lngStart As Long
Dim rngWork As Range
Dim rngTarg As Range
Dim rngHit As Range

'change sheetbames to suit
Set wsData = Worksheets("RETSEL")
Set wsTarg = Worksheets("result")
lngStart = 1

Application.ScreenUpdating = False
With wsData
  Do While lngStart < .Cells(.Rows.Count, "B").End(xlUp).Row
    Set rngWork = .Cells(lngStart, "E").CurrentRegion
    With rngWork
      If .Range("B" & .Rows.Count).Value = "SUMMING" And _
          .Range("H" & .Rows.Count).Interior.ColorIndex = 6 Then
        Set rngHit = wsTarg.Columns(5).Find(.Cells(2, "E").Value, LookIn:=xlValues)
        If Not rngHit Is Nothing Then
          Set rngTarg = rngHit.CurrentRegion
          rngTarg.Cells(rngTarg.Rows.Count, "H").Value = .Range("H" & .Rows.Count).Value
          Set rngTarg = Nothing
          Set rngHit = Nothing
        End If
      End If
      lngStart = .Cells(.Rows.Count, .Columns.Count).End(xlDown).Row
    End With
    Set rngWork = Nothing
  Loop
End With

Application.ScreenUpdating = False
Set wsTarg = Nothing
Set wsData = Nothing
End Sub
```

Ciao,
Holger


----------



## KalilMe (Sunday at 9:49 AM)

@HaHoBe 
thanks  but  I  no  know  what's  the  problem  !
there  is  no  error  and  doesn't  show  anything  in result  sheet


----------



## mumps (Sunday at 10:09 AM)

Try:

```
Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, rng As Range, srcRng As Range
    With Sheets("RETSEL")
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("A1:H" & LastRow).AutoFilter Field:=8, Criteria1:=RGB(153, 204, 0), Operator:=xlFilterCellColor
        Set srcRng = .Range("H2:H" & LastRow).SpecialCells(xlCellTypeVisible)
        .Range("A1").AutoFilter
        For Each rng In srcRng
            .Range("H" & rng.Row).CurrentRegion.Copy Sheets("result").Cells(Sheets("result").Rows.Count, "A").End(xlUp).Offset(4)
        Next rng
    End With
    Sheets("result").Range("A1").Resize(4).EntireRow.Delete
    Application.ScreenUpdating = True
End Sub
```


----------



## HaHoBe (Sunday at 10:32 AM)

Hi KalilMe,


```
Public Sub MrE_1226327_1700811_mod()
' https://www.mrexcel.com/board/threads/copy-individual-range-based-on-highlighted-last-cell-from-sheet-to-another.1226327/

'Assumptions: Code-Nr to transfer to is located on Column E in the second row of the area to work on
'             "SUMMING" is in capital letter and located on Column B in the last row of the area to work on
'             ColorIndex for highlighting is vbYellow or 6
'             Value to transfer is located on Column H in the last row of the area to work on

'/// Please note: ALWAYS run the macros on a copy of your Workbook !!!!

Dim wsTarg As Worksheet
Dim wsData As Worksheet
Dim lngStart As Long
Dim lngCopy As Long
Dim rngWork As Range
Dim rngTarg As Range
Dim rngHit As Range

'change sheetbames to suit
Set wsData = Worksheets("RETSEL")
Set wsTarg = Worksheets("result")

wsTarg.Cells.Clear

lngStart = 1
lngCopy = 1

Application.ScreenUpdating = False
With wsData
  Do While lngStart < .Cells(.Rows.Count, "B").End(xlUp).Row
    Set rngWork = .Cells(lngStart, "E").CurrentRegion
    With rngWork
      If .Range("B" & .Rows.Count).Value = "SUMMING" And _
          .Range("H" & .Rows.Count).Interior.ColorIndex = 6 Then
        wsTarg.Cells(lngCopy, 1).Resize(.Rows.Count, .Columns.Count).Value = .Value
        lngCopy = wsTarg.Cells(wsTarg.Rows.Count, "H").End(xlUp).Row + 3
      End If
      lngStart = .Cells(.Rows.Count, .Columns.Count).End(xlDown).Row
    End With
  Loop
End With

Application.ScreenUpdating = False
Set rngWork = Nothing
Set wsTarg = Nothing
Set wsData = Nothing
End Sub
```

Holger


----------



## KalilMe (Sunday at 12:22 PM)

@mumps  thanks  
sorry  I  said  that  !  the  code  is  really  slow.


----------



## KalilMe (Sunday at 1:25 PM)

@HaHoBe 
again there is no error and doesn't show anything in result sheet !


----------



## KalilMe (Sunday at 4:04 AM)

Hello
I  want  copying   for  each  range  just  contains  higlighted  cell   in column H for  the  last  row (SUMMING) from sheet to another 
source data
Copy of TR.xlsmABCDEFGH1CODE2FR-003ITEMDATEGOODSTYPEPRQTYUNITTOTAL4101/01/2021BANANAFOPL200.0012.002400.005207/01/2021BANANAFOPL450.0012.005400.006308/01/2021BANANAFOPL500.0019.579785.717414/01/2021BANANAFOPL800.0025.3620285.718515/01/2021BANANAFOPL850.0026.3222373.219SUMMING2800.0060244.64101112CODE13FR-0114ITEMDATEGOODSTYPEPRQTYUNITTOTAL15102/01/2021APPLEFRPPL100.0014.001400.0016209/01/2021APPLEFRPPL550.0020.5411294.6417316/01/2021APPLEFRPPL900.0027.2924557.1418SUMMING1550.0037251.79192021CODE22FR-0223ITEMDATEGOODSTYPEPRQTYUNITTOTAL24103/01/2021PEACHFRLLP300.0015.004500.0025210/01/2021PEACHFRLLP600.0021.5012900.0026317/01/2021PEACHFRLLP950.0028.2526837.5027SUMMING1850.0044237.50282930CODE31FR-0332ITEMDATEGOODSTYPEPRQTYUNITTOTAL33104/01/2021PEARFRTTL300.0012.003600.0034211/01/2021PEARFRTTL650.0022.4614601.7935318/01/2021BANANAFOPL1000.0029.2129214.2936SUMMING1950.0047416.07373839CODE40FR-0441ITEMDATEGOODSTYPEPRQTYUNITTOTAL42105/01/2021STRWBERRAYFRMML350.0020.007000.0043212/01/2021STRWBERRAYFRMML700.0023.4316400.0044319/01/2021APPLEFRPPL1050.0030.1831687.5045SUMMING2100.0055087.50RETSEL

result  like  this 
Copy of TR.xlsmABCDEFGH1CODE2FR-003ITEMDATEGOODSTYPEPRQTYUNITTOTAL4101/01/2021BANANAFOPL200.0012.002400.005207/01/2021BANANAFOPL450.0012.005400.006308/01/2021BANANAFOPL500.0019.579785.717414/01/2021BANANAFOPL800.0025.3620285.718515/01/2021BANANAFOPL850.0026.3222373.219SUMMING2800.0060244.64101112CODE13FR-0214ITEMDATEGOODSTYPEPRQTYUNITTOTAL15103/01/2021PEACHFRLLP300.0015.004500.0016210/01/2021PEACHFRLLP600.0021.5012900.0017317/01/2021PEACHFRLLP950.0028.2526837.5018SUMMING1850.0044237.50192021CODE22FR-0423ITEMDATEGOODSTYPEPRQTYUNITTOTAL24105/01/2021STRWBERRAYFRMML350.0020.007000.0025212/01/2021STRWBERRAYFRMML700.0023.4316400.0026319/01/2021APPLEFRPPL1050.0030.1831687.5027SUMMING2100.0055087.50result

*note: *the data are increasable and changeable in sheet RETSEL


----------



## HaHoBe (Sunday at 1:54 PM)

Hi KalilMe,


```
Public Sub MrE_1226327_1700811_mod02()
' https://www.mrexcel.com/board/threads/copy-individual-range-based-on-highlighted-last-cell-from-sheet-to-another.1226327/

'Assumptions: Code-Nr to transfer to is located on Column E in the second row of the area to work on
'             "SUMMING" is in capital letter and located on Column B in the last row of the area to work on
'             ColorIndex for highlighting is vbYellow or 6
'             Value to transfer is located on Column H in the last row of the area to work on

'changed the color to check from 6 (vbYellow) to 52377

Dim wsTarg As Worksheet
Dim wsData As Worksheet
Dim lngStart As Long
Dim lngCopy As Long
Dim rngWork As Range
Dim rngTarg As Range
Dim rngHit As Range

'change sheetbames to suit
Set wsData = Worksheets("RETSEL")
Set wsTarg = Worksheets("result")
lngStart = 1
lngCopy = 1

Application.ScreenUpdating = False
With wsData
  Do While lngStart < .Cells(.Rows.Count, "B").End(xlUp).Row
    Set rngWork = .Cells(lngStart, "E").CurrentRegion
    With rngWork
      If .Range("B" & .Rows.Count).Value = "SUMMING" And _
          .Range("H" & .Rows.Count).Interior.Color = 52377 Then
        .Copy wsTarg.Cells(lngCopy, 1)
        lngCopy = wsTarg.Cells(wsTarg.Rows.Count, "H").End(xlUp).Row + 3
      End If
      lngStart = .Cells(.Rows.Count, .Columns.Count).End(xlDown).Row
    End With
  Loop
End With

With Sheets("result")
  .Range("A1:H1").EntireColumn.AutoFit
  Application.Goto .Range("A1")
End With

Application.ScreenUpdating = False
Set rngWork = Nothing
Set wsTarg = Nothing
Set wsData = Nothing

End Sub
```

Holger


----------



## KalilMe (Monday at 12:21 AM)

@HaHoBe 
finally  works  but not as what  I  want. 
first is  still  slow  like @shinigamilight 
second  your code repeats copying  to the  bottom  when run  the  macro  everytime  .
It should  just replace when update  data.  I mean clear in sheet result before  bring  data.
Thanks for your trying.


----------



## HaHoBe (Monday at 2:35 AM)

Hi KalilMe,

please define *slow*. Have you ever considered your data setup to be a possible reason for the runtime of the provided codes?

On a test the Immediate Window brought up this when a timer had been used:


```
elapsed time for procedure: 4,126953125 sec
last row to check: 10.145
```

How fast do you think the procedure should be?


Regarding the multiple use of the procedure just add one line of code like


```
lngCopy = 1

'delete data on sheet result
wsTarg.Range("A1:N1").EntireColumn.Delete

Application.ScreenUpdating = False
```

And I really wonder as this has never been mentioned before as it has not been part of any code supplied.

Holger


----------



## HaHoBe (Monday at 5:54 AM)

Knowing that it relies on the computer used, Standalone or Network, OS, Processor, RAM, Applications running, HDD I wanted to know about the times for the 3 different codes supplied on my computer (Laptop Standalone no Network, Windows11, 8 GB RAM, Shared Memory Graphics, OS, Internet Securoty, InternetConnection, FireFox, Excel2019):


```
elapsed time for procedure 'dream': 3,95703125 sec
elapsed time for procedure 'MrE_1226327_1700811_mod03': 3,921875 sec
elapsed time for procedure 'CopyData': 3,921875 sec
----
elapsed time for procedure 'MrE_1226327_1700811_mod03': 4,09765625 sec
elapsed time for procedure 'CopyData': 3,95703125 sec
elapsed time for procedure 'dream': 3,89453125 sec
----
elapsed time for procedure 'CopyData': 3,94921875 sec
elapsed time for procedure 'dream': 3,90625 sec
elapsed time for procedure 'MrE_1226327_1700811_mod03': 3,90625 sec
```

I modified the codes supplied to delete any content on sheet "result" and implemented the timer. In "dream" I added the object to the worksheet "RETSEL"  for lr and disabled ScreenUpdating for running of the code (changedk to be of Type Long as lr is of that Type). The difference of 0.02 seconds does not point out which code is fastest (I would choose any of the other codes as they are much shorter than mine).

Holger


----------



## KalilMe (Monday at 10:37 AM)

@HaHoBe 
this  is  what  I  got 
macro dream is   10.3 sec 
macro CopyData  is 6.8 
macro MrE_1226327_1700811_mod02  is  7.2
so nobody using at least (array & dic)  to make fast I believe it  can achieve to reach 2.5 is acceptable
thanks   for  all


----------



## HaHoBe (Monday at 11:30 AM)

Hi KalilMe,

as you know how to solve the problem I would be glad to learn how to integrate the background color into either array or dictionary. Please let me know - I'm old but still trying to learn new tricks.

Holger


----------



## HaHoBe (Tuesday at 7:56 AM)

Hi KalilMe,

my remarks above where meant to transfer the setup without any change to an array. If I enter another column (showing the color of the cells in the last column of the original data) a code like the following should work:


```
Sub MrE_1226327_1700A0F()
' https://www.mrexcel.com/board/threads/copy-individual-range-based-on-highlighted-last-cell-from-sheet-to-another.1226327/

' using Arrays to copy over the values
' prior to assigning the range to the array a new column will be inserted to the right:
'     reading out the color for the last column of original data by UDF
' additional column will be deleted at end of procedure

Dim dblStart As Double
Dim dblEnd As Double

Dim lngStart As Long
Dim lngEnd As Long
Dim lngLast As Long
Dim lngNewCol As Long
Dim lngLoop As Long
Dim lngVar As Long
Dim lngWrite As Long
Dim lngCnt As Long

Dim arr() As Variant
Dim var() As Variant

Dim wsTest As Worksheet
Dim wsTarg As Worksheet
Dim wsData As Worksheet

Application.ScreenUpdating = False
dblStart = Timer

'please adjust the sheetnames
Set wsData = Worksheets("SPEEDTEST")
Set wsTarg = Worksheets("result")

wsTarg.Cells.Delete

With wsData
  lngLast = .Cells(.Rows.Count, "H").End(xlUp).Row
  lngNewCol = .Cells(3, .Columns.Count).End(xlToLeft).Column + 1
  
  .Cells(1, lngNewCol).EntireColumn.Insert
  With .Range(.Cells(1, lngNewCol), .Cells(lngLast, lngNewCol))
    .FormulaR1C1 = "=fncCellInteriorColor(RC[-1])"
    .Value = .Value
  End With
  
  arr = .Range("A1", .Cells(lngLast, lngNewCol)).Value
  
  For lngCnt = 1 To UBound(arr, 1)
    If arr(lngCnt, lngNewCol) = 65535 Then
      lngStart = lngCnt - 2
    ElseIf arr(lngCnt, lngNewCol) = 52377 Then
      lngEnd = lngCnt
      ReDim var(lngEnd - lngStart + 2, 8)
      lngWrite = 0
      For lngLoop = lngStart To lngEnd
        lngWrite = lngWrite + 1
        For lngVar = 1 To 8
          var(lngWrite, lngVar - 1) = arr(lngLoop, lngVar)
        Next lngVar
      Next lngLoop
      wsTarg.Cells(wsTarg.Rows.Count, 1).End(xlUp).Offset(3).Resize(UBound(var), 8).Value = var
      Erase var
    End If
  Next lngCnt
  .Cells(1, lngNewCol).EntireColumn.Delete
End With
With wsTarg
  .Range("A1").Resize(4).EntireRow.Delete
  .Range("A1:H1").EntireColumn.AutoFit
  Application.Goto .Range("A1"), True
End With

dblEnd = Timer
Application.ScreenUpdating = True

Debug.Print "elapsed time for procedure 'MrE_1226327_1700A0F': " & dblEnd - dblStart & " sec"

End Sub

Function fncCellInteriorColor(rng As Range) As Long
  fncCellInteriorColor = rng.Interior.Color
End Function
```

I haven't found a way to access the rows of the orignal array at once so another array is used and filled via loop (I know: old, learning nothing new and rusty). On Worksheets("SPEEDTEST") going up to row 10145 timer showed


```
elapsed time for procedure 'MrE_1226327_1700A0F': 0,75390625 sec
```

Please make sure that the UDF is copied over as well (in my test both were located in the same module) and that there is only one function of that name present in the workbook.

Holger


----------



## kvsrinivasamurthy (Tuesday at 9:42 AM)

Try this this faster.

```
Sub DataColoured()
Dim col As Long, Lr As Long, T As Long, Ro As Long
Dim M
Application.ScreenUpdating = False
With Sheets("Sheet1")
Lr = .Range("B" & Rows.Count).End(xlUp).Row
col = .Range("h9").Interior.Color
M = Filter(Evaluate("transpose(IF(Sheet1!B2:B" & Lr & "=""SUMMING"",Row(Sheet1!B2:B" & Lr & "),False))"), False, False)
Sheets("Sheet2").Cells.Clear
For T = 0 To UBound(M)
If .Range("H" & M(T)).Interior.Color = col Then
If T = 0 Then Ro = 0 Else Ro = 5
.Range("H" & M(T)).CurrentRegion.Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(Ro, 0)
End If
Next T
End With
Application.ScreenUpdating = True
End Sub
```


----------



## shinigamilight (Tuesday at 10:09 AM)

HaHoBe said:


> Hi KalilMe,
> 
> my remarks above where meant to transfer the setup without any change to an array. If I enter another column (showing the color of the cells in the last column of the original data) a code like the following should work:
> 
> ...


Amazing code, I could have never come up with this.


----------



## HaHoBe (Tuesday at 10:19 AM)

Hi kvsrinivasamurthy,

running your code on my sheet _SpeedTest_ brings up


```
elapsed time for procedure 'DataColoured': 4,015625 sec
elapsed time for procedure 'DataColoured': 3,796875 sec
elapsed time for procedure 'DataColoured': 3,9921875 sec
```


@shinigamilight:

it took some time for me to figure this one out. I started from a totally different point and am still loking for a way to avoid the loops for passing the data. 

Holger


----------



## KalilMe (Sunday at 4:04 AM)

Hello
I  want  copying   for  each  range  just  contains  higlighted  cell   in column H for  the  last  row (SUMMING) from sheet to another 
source data
Copy of TR.xlsmABCDEFGH1CODE2FR-003ITEMDATEGOODSTYPEPRQTYUNITTOTAL4101/01/2021BANANAFOPL200.0012.002400.005207/01/2021BANANAFOPL450.0012.005400.006308/01/2021BANANAFOPL500.0019.579785.717414/01/2021BANANAFOPL800.0025.3620285.718515/01/2021BANANAFOPL850.0026.3222373.219SUMMING2800.0060244.64101112CODE13FR-0114ITEMDATEGOODSTYPEPRQTYUNITTOTAL15102/01/2021APPLEFRPPL100.0014.001400.0016209/01/2021APPLEFRPPL550.0020.5411294.6417316/01/2021APPLEFRPPL900.0027.2924557.1418SUMMING1550.0037251.79192021CODE22FR-0223ITEMDATEGOODSTYPEPRQTYUNITTOTAL24103/01/2021PEACHFRLLP300.0015.004500.0025210/01/2021PEACHFRLLP600.0021.5012900.0026317/01/2021PEACHFRLLP950.0028.2526837.5027SUMMING1850.0044237.50282930CODE31FR-0332ITEMDATEGOODSTYPEPRQTYUNITTOTAL33104/01/2021PEARFRTTL300.0012.003600.0034211/01/2021PEARFRTTL650.0022.4614601.7935318/01/2021BANANAFOPL1000.0029.2129214.2936SUMMING1950.0047416.07373839CODE40FR-0441ITEMDATEGOODSTYPEPRQTYUNITTOTAL42105/01/2021STRWBERRAYFRMML350.0020.007000.0043212/01/2021STRWBERRAYFRMML700.0023.4316400.0044319/01/2021APPLEFRPPL1050.0030.1831687.5045SUMMING2100.0055087.50RETSEL

result  like  this 
Copy of TR.xlsmABCDEFGH1CODE2FR-003ITEMDATEGOODSTYPEPRQTYUNITTOTAL4101/01/2021BANANAFOPL200.0012.002400.005207/01/2021BANANAFOPL450.0012.005400.006308/01/2021BANANAFOPL500.0019.579785.717414/01/2021BANANAFOPL800.0025.3620285.718515/01/2021BANANAFOPL850.0026.3222373.219SUMMING2800.0060244.64101112CODE13FR-0214ITEMDATEGOODSTYPEPRQTYUNITTOTAL15103/01/2021PEACHFRLLP300.0015.004500.0016210/01/2021PEACHFRLLP600.0021.5012900.0017317/01/2021PEACHFRLLP950.0028.2526837.5018SUMMING1850.0044237.50192021CODE22FR-0423ITEMDATEGOODSTYPEPRQTYUNITTOTAL24105/01/2021STRWBERRAYFRMML350.0020.007000.0025212/01/2021STRWBERRAYFRMML700.0023.4316400.0026319/01/2021APPLEFRPPL1050.0030.1831687.5027SUMMING2100.0055087.50result

*note: *the data are increasable and changeable in sheet RETSEL


----------



## KalilMe (Tuesday at 11:42 PM)

@HaHoBe 
thanks  again  your  code gives  about 1.00 sec  for  me  yes  this  is  really  fast   than  before ,but  you  ignore  formatting 
that's  why   your  code  is   faster  than Kvsrinivasamurthy . shouldn't  ignore formatting .

​


----------



## KalilMe (Tuesday at 11:46 PM)

@kvsrinivasamurthy  this  is  better  
it  gives  about  3.0566
thanks . if  you could  achieve to  reach 1.00  sec  with  formatting  will  be  great .


----------



## kvsrinivasamurthy (Wednesday at 2:08 AM)

Try this code. Let us know How much time this code takes.
Code creates new sheet "Sheet2New"

```
Sub DataColoured()
Dim col As Long, Lr As Long, T As Long, Ro As Long
Dim M
Application.ScreenUpdating = False
Sheets("Sheet1").Copy Before:=Sheets(1)
ActiveSheet.Name = "Sheet2New"
Lr = Range("B" & Rows.Count).End(xlUp).Row
col = Range("h9").Interior.Color
M = Filter(Evaluate("transpose(IF(Sheet1!B2:B" & Lr & "=""SUMMING"",Row(Sheet1!B2:B" & Lr & "),False))"), False, False)

For T = 0 To UBound(M)
If Range("H" & M(T)).Interior.Color <> col Then
With Range("H" & M(T)).CurrentRegion
.Resize(.Rows.Count + 2).Delete Shift:=xlUp
End With
End If
Next T
Application.ScreenUpdating = True
End Sub
```


----------



## kvsrinivasamurthy (Wednesday at 2:26 AM)

Try this code also. Let us know How much time this code takes.
Code creates new sheet "Sheet3New"

```
Sub DataColoured3()
Dim col As Long, Lr As Long, T As Long, Ro As Long
Dim M, Adr
Application.ScreenUpdating = False
Sheets("Sheet1").Copy Before:=Sheets(1)
ActiveSheet.Name = "Sheet3New"
Lr = Range("B" & Rows.Count).End(xlUp).Row
col = Range("h9").Interior.Color
M = Filter(Evaluate("transpose(IF(Sheet1!B2:B" & Lr & "=""SUMMING"",Row(Sheet1!B2:B" & Lr & "),False))"), False, False)

For T = 0 To UBound(M)
If Range("H" & M(T)).Interior.Color <> col Then
With Range("H" & M(T)).CurrentRegion
Adr = Adr & "," & .Resize(.Rows.Count + 2).Address
End With
End If
Next T
If Adr <> "" Then Adr = Mid(Adr, 2)
Range(Adr).Delete Shift:=xlUp
Application.ScreenUpdating = True
End Sub
```


----------



## KalilMe (Wednesday at 3:26 AM)

@kvsrinivasamurthy 
Code in post#23  gives 1.10
Code in post#24  gives error method range of object _global failed n this  line 

```
Range(Adr).Delete Shift:=xlUp
```
about   after add new  sheet  , can  you  make  just  updtating data for   the  added new  sheet  instead  of  shows  error  when run the  macro  every  time  please?


----------



## HaHoBe (Wednesday at 5:21 AM)

Hi KalilMe,


```
Public Sub MrE_1226327_1700B0B()

' https://www.mrexcel.com/board/threads/copy-individual-range-based-on-highlighted-last-cell-from-sheet-to-another.1226327/

Dim wsTarg As Worksheet
Dim wsData As Worksheet
Dim lngStart As Long
Dim rngWork As Range
Dim rngTarg As Range
Dim dblStart As Double
Dim dblEnd As Double

dblStart = Timer

'change sheetnames to suit
Set wsData = Worksheets("SpeedTest")
Set wsTarg = Worksheets("result")
lngStart = 1

wsTarg.Range("A1:N1").EntireColumn.Delete

Application.ScreenUpdating = False
With wsData
  Do While lngStart < .Cells(.Rows.Count, "B").End(xlUp).Row
    Set rngTarg = .Cells(lngStart, "E").CurrentRegion
    With rngTarg
      If .Range("H" & .Rows.Count).Interior.Color = 52377 Then
        If rngWork Is Nothing Then
          Set rngWork = rngTarg.Resize(rngTarg.Rows.Count + 2)
        Else
          Set rngWork = Union(rngWork, rngTarg.Resize(rngTarg.Rows.Count + 2))
        End If
      End If
      lngStart = .Cells(.Rows.Count, .Columns.Count).End(xlDown).Row
    End With
  Loop
End With

With wsTarg
  rngWork.Copy wsTarg.Cells(1, 1)
  .Range("A1:H1").EntireColumn.AutoFit
  Application.Goto .Range("A1"), True
End With

dblEnd = Timer

Debug.Print "elapsed time for procedure 'MrE_1226327_1700B0B': " & dblEnd - dblStart & " sec"

Application.ScreenUpdating = False
Set rngWork = Nothing
Set rngTarg = Nothing
Set wsTarg = Nothing
Set wsData = Nothing

End Sub
```


```
elapsed time for procedure 'MrE_1226327_1700B0B': 0,859375 sec
```

Holger


----------



## kvsrinivasamurthy (Wednesday at 6:19 AM)

I have removed the name for new sheet.  If required pl change the name of the sheet manually.
I am not getting error while running macro. If problem is still there Pl upload file.

```
Sub DataColoured3()
Dim col As Long, Lr As Long, T As Long, Ro As Long
Dim M, Adr
Application.ScreenUpdating = False
Sheets("Sheet1").Copy Before:=Sheets(1)
Lr = Range("B" & Rows.Count).End(xlUp).Row
col = Range("h9").Interior.Color
M = Filter(Evaluate("transpose(IF(Sheet1!B2:B" & Lr & "=""SUMMING"",Row(Sheet1!B2:B" & Lr & "),False))"), False, False)

For T = 0 To UBound(M)
If Range("H" & M(T)).Interior.Color <> col Then
With Range("H" & M(T)).CurrentRegion
Adr = Adr & "," & .Resize(.Rows.Count + 2).Address
End With
End If
Next T
If Adr <> "" Then Adr = Mid(Adr, 2): Range(Adr).Delete Shift:=xlUp
Application.ScreenUpdating = True
End Sub
```


----------



## KalilMe (Wednesday at 6:38 AM)

@HaHoBe 
awesome ! 
gives 0.480 sec seems  @kvsrinivasamurthy's code  is  faster  than  you  .


----------



## KalilMe (Wednesday at 6:41 AM)

@kvsrinivasamurthy
magnificent !
gives 0.110 sec


> I have removed the name for new sheet. If required pl change the name of the sheet manually


I don't  need  add  new  sheet every time  when  I  run  macro every  time ,   just  work at  the  sheet has  already added . could  be ,please?.


----------



## kvsrinivasamurthy (Wednesday at 6:48 AM)

You mean every time you want add new data to sheet2 along with already existing data or replace already existing data in sheet2.


----------



## KalilMe (Sunday at 4:04 AM)

Hello
I  want  copying   for  each  range  just  contains  higlighted  cell   in column H for  the  last  row (SUMMING) from sheet to another 
source data
Copy of TR.xlsmABCDEFGH1CODE2FR-003ITEMDATEGOODSTYPEPRQTYUNITTOTAL4101/01/2021BANANAFOPL200.0012.002400.005207/01/2021BANANAFOPL450.0012.005400.006308/01/2021BANANAFOPL500.0019.579785.717414/01/2021BANANAFOPL800.0025.3620285.718515/01/2021BANANAFOPL850.0026.3222373.219SUMMING2800.0060244.64101112CODE13FR-0114ITEMDATEGOODSTYPEPRQTYUNITTOTAL15102/01/2021APPLEFRPPL100.0014.001400.0016209/01/2021APPLEFRPPL550.0020.5411294.6417316/01/2021APPLEFRPPL900.0027.2924557.1418SUMMING1550.0037251.79192021CODE22FR-0223ITEMDATEGOODSTYPEPRQTYUNITTOTAL24103/01/2021PEACHFRLLP300.0015.004500.0025210/01/2021PEACHFRLLP600.0021.5012900.0026317/01/2021PEACHFRLLP950.0028.2526837.5027SUMMING1850.0044237.50282930CODE31FR-0332ITEMDATEGOODSTYPEPRQTYUNITTOTAL33104/01/2021PEARFRTTL300.0012.003600.0034211/01/2021PEARFRTTL650.0022.4614601.7935318/01/2021BANANAFOPL1000.0029.2129214.2936SUMMING1950.0047416.07373839CODE40FR-0441ITEMDATEGOODSTYPEPRQTYUNITTOTAL42105/01/2021STRWBERRAYFRMML350.0020.007000.0043212/01/2021STRWBERRAYFRMML700.0023.4316400.0044319/01/2021APPLEFRPPL1050.0030.1831687.5045SUMMING2100.0055087.50RETSEL

result  like  this 
Copy of TR.xlsmABCDEFGH1CODE2FR-003ITEMDATEGOODSTYPEPRQTYUNITTOTAL4101/01/2021BANANAFOPL200.0012.002400.005207/01/2021BANANAFOPL450.0012.005400.006308/01/2021BANANAFOPL500.0019.579785.717414/01/2021BANANAFOPL800.0025.3620285.718515/01/2021BANANAFOPL850.0026.3222373.219SUMMING2800.0060244.64101112CODE13FR-0214ITEMDATEGOODSTYPEPRQTYUNITTOTAL15103/01/2021PEACHFRLLP300.0015.004500.0016210/01/2021PEACHFRLLP600.0021.5012900.0017317/01/2021PEACHFRLLP950.0028.2526837.5018SUMMING1850.0044237.50192021CODE22FR-0423ITEMDATEGOODSTYPEPRQTYUNITTOTAL24105/01/2021STRWBERRAYFRMML350.0020.007000.0025212/01/2021STRWBERRAYFRMML700.0023.4316400.0026319/01/2021APPLEFRPPL1050.0030.1831687.5027SUMMING2100.0055087.50result

*note: *the data are increasable and changeable in sheet RETSEL


----------



## KalilMe (Wednesday at 7:35 AM)

should replace already existing data in sheet2.


----------



## HaHoBe (Wednesday at 8:30 AM)

Hi kvsrinivasamurthy,

Code from #23 modified:


```
Sub DataColoured2()
Dim col As Long, Lr As Long, T As Long, Ro As Long
Dim M
Dim dblStart As Double
Dim dblEnd As Double

dblStart = Timer
Application.ScreenUpdating = False
Sheets("Sheet1").Copy Before:=Sheets(1)
ActiveSheet.Name = "DataColoured2"
Lr = Range("B" & Rows.Count).End(xlUp).Row
col = Range("h9").Interior.Color
M = Filter(Evaluate("transpose(IF(Sheet1!B2:B" & Lr & "=""SUMMING"",Row(Sheet1!B2:B" & Lr & "),False))"), False, False)

For T = 0 To UBound(M)
  If Range("H" & M(T)).Interior.Color <> col Then
    With Range("H" & M(T)).CurrentRegion
      .Resize(.Rows.Count + 2).Delete Shift:=xlUp
    End With
  End If
Next T
Application.ScreenUpdating = True
dblEnd = Timer

Debug.Print "elapsed time for procedure 'DataColoured2': " & dblEnd - dblStart & " sec"
End Sub
```

brings up this (only a part):

MrE_1226327_1700A0F_copy individual rang_230110.xlsmABCDEFGH98CODE99FR-00175100ITEMDATEGOODSTYPEPRQTYUNITTOTAL101144200PEARFRTTL300123600102244207PEARFRTTL650224.642.857.142.857146.017.857.142.857103344214BANANAFOPL1000292.142.857.142.857292.142.857.142.857104SUMMING1950474.160.714.285.714105106TOTAL107CODE7000108FR-00184164.000.000.000.001109ITEMDATEGOODSTYPEPRQTYUNIT316.875.000.000.001110144201STRWBERRAYFRMML35020550.875.000.000.001111244208STRWBERRAYFRMML700234.285.714.285.715112344215APPLEFRPPL1050301.785.714.285.715113SUMMING2100114115CODE1400116FR-00204112.946.428.571.429117ITEMDATEGOODSTYPEPRQTYUNIT245.571.428.571.429118144198APPLEFRPPL10014372.517.857.142.857119244205APPLEFRPPL550205.357.142.857.143120344212APPLEFRPPL900272.857.142.857.143121SUMMING1550DataColoured2

elapsed time for procedure 'DataColoured2': 35,08203125 sec

What am I doing wrong?

Holger


----------



## kvsrinivasamurthy (Wednesday at 8:54 AM)

Try

```
Sub DataColoured3()
Dim col As Long, Lr As Long, T As Long, Ro As Long
Dim M, Adr
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Sheet2").Delete
On Error GoTo 0
Sheets("Sheet1").Copy Before:=Sheets(1)
ActiveSheet.Name = "Sheet2"
Lr = Range("B" & Rows.Count).End(xlUp).Row
col = Range("h9").Interior.Color
M = Filter(Evaluate("transpose(IF(Sheet1!B2:B" & Lr & "=""SUMMING"",Row(Sheet1!B2:B" & Lr & "),False))"), False, False)

For T = 0 To UBound(M)
If Range("H" & M(T)).Interior.Color <> col Then
With Range("H" & M(T)).CurrentRegion
Adr = Adr & "," & .Resize(.Rows.Count + 2).Address
End With
End If
Next T
If Adr <> "" Then Range(Mid(Adr, 2)).Delete Shift:=xlUp  
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
```


----------



## kvsrinivasamurthy (Wednesday at 8:58 AM)

Ref Post#32.
Sorry. I don't know.


----------



## kvsrinivasamurthy (Wednesday at 9:10 AM)

Slight change in code

```
Sub DataColoured3()
Dim col As Long, Lr As Long, T As Long, Ro As Long
Dim M, Adr
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Sheet2").Delete
On Error GoTo 0
Sheets("Sheet1").Copy After:=Sheets("Sheet1")
ActiveSheet.Name = "Sheet2"
Lr = Range("B" & Rows.Count).End(xlUp).Row
col = Range("h9").Interior.Color
M = Filter(Evaluate("transpose(IF(Sheet1!B2:B" & Lr & "=""SUMMING"",Row(Sheet1!B2:B" & Lr & "),False))"), False, False)

For T = 0 To UBound(M)
If Range("H" & M(T)).Interior.Color <> col Then
With Range("H" & M(T)).CurrentRegion
Adr = Adr & "," & .Resize(.Rows.Count + 2).Address
End With
End If
Next T
If Adr <> "" Then Range(Mid(Adr, 2)).Delete Shift:=xlUp   'Adr = Mid(Adr, 2):
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
```


----------



## HaHoBe (Wednesday at 9:32 AM)

Hi kvsrinivasamurthy,

OP claims to have about 8k of rows, the testsheet I used to compare the codes goes up to row 10145.

Maybe it's the length of the string _Adr_ (I think to remember about a limit for any string for a range). Immediate Window shows


```
contents of Adr: ,$A$12:$H$20,$A$30:$H$38,$A$59:$H$70,$A$80:$H$88,$A$109:$H$117,$A$127:$H$135,$A$156:$H$164,$A$174:$H$182,$A$203:$H$211,$A$221:$H$229,$A$250:$H$258,$A$268:$H$276,$A$297:$H$305,$A$315:$H$323,$A$344:$H$352,$A$362:$H$370,$A$391:$H$399,$A$409:$H$417,$A$438:$H$446,$A$456:$H$464,$A$485:$H$493,$A$503:$H$511,$A$532:$H$540,$A$550:$H$558,$A$579:$H$587,$A$597:$H$605,$A$626:$H$634,$A$644:$H$652,$A$673:$H$681,$A$691:$H$699,$A$720:$H$728,$A$738:$H$746,$A$767:$H$775,$A$785:$H$793,$A$814:$H$822,$A$832:$H$840,$A$861:$H$869,$A$879:$H$887,$A$908:$H$916,$A$926:$H$934,$A$955:$H$963,$A$973:$H$981,$A$1002:$H$1010,$A$1020:$H$1028,$A$1049:$H$1057,$A$1067:$H$1075,$A$1096:$H$1104,$A$1114:$H$1122,$A$1143:$H$1151,$A$1161:$H$1169,$A$1190:$H$1198,$A$1208:$H$1216,$A$1237:$H$1245,$A$1255:$H$1263,$A$1284:$H$1292,$A$1302:$H$1310,$A$1331:$H$1339,$A$1349:$H$1357,$A$1378:$H$1386,$A$1396:$H$1404,$A$1425:$H$1433,$A$1443:$H$1451,$A$1472:$H$1480,$A$1490:$H$1498,$A$1519:$H$1527,$A$1537:$H$1545,$A$1566:$H$1574,$A$1584:$H$1592,$A$1613:$
H$1621,$A$1631:$H$1639,$A$1660:$H$1668,$A$1678:$H$1686,$A$1706:$H$1714,$A$1724:$H$1732,$A$1753:$H$1761,$A$1771:$H$1779,$A$1800:$H$1808,$A$1818:$H$1826,$A$1847:$H$1855,$A$1865:$H$1873,$A$1894:$H$1902,$A$1912:$H$1920,$A$1941:$H$1949,$A$1959:$H$1967,$A$1988:$H$1996,$A$2006:$H$2014,$A$2035:$H$2043,$A$2053:$H$2061,$A$2082:$H$2090,$A$2100:$H$2108,$A$2129:$H$2137,$A$2147:$H$2155,$A$2176:$H$2184,$A$2194:$H$2202,$A$2223:$H$2231,$A$2241:$H$2249,$A$2270:$H$2278,$A$2288:$H$2296,$A$2317:$H$2325,$A$2335:$H$2343,$A$2364:$H$2372,$A$2382:$H$2390,$A$2411:$H$2419,$A$2429:$H$2437,$A$2458:$H$2466,$A$2476:$H$2484,$A$2505:$H$2513,$A$2523:$H$2531,$A$2552:$H$2560,$A$2570:$H$2578,$A$2599:$H$2607,$A$2617:$H$2625,$A$2646:$H$2654,$A$2664:$H$2672,$A$2693:$H$2701,$A$2711:$H$2719,$A$2740:$H$2748,$A$2758:$H$2766,$A$2787:$H$2795,$A$2805:$H$2813,$A$2834:$H$2842,$A$2852:$H$2860,$A$2881:$H$2889,$A$2899:$H$2907,$A$2928:$H$2936,$A$2946:$H$2954,$A$2975:$H$2983,$A$2993:$H$3001,$A$3022:$H$3030,$A$3040:$H$3048,$A$3069:$H$3077,$A$3087:$H$3095,$A$3116:
$H$3124,$A$3134:$H$3142,$A$3163:$H$3171,$A$3181:$H$3189,$A$3210:$H$3218,$A$3228:$H$3236,$A$3257:$H$3265,$A$3275:$H$3283,$A$3304:$H$3312,$A$3322:$H$3330,$A$3351:$H$3359,$A$3369:$H$3377,$A$3398:$H$3406,$A$3416:$H$3424,$A$3445:$H$3453,$A$3463:$H$3471,$A$3492:$H$3500,$A$3510:$H$3518,$A$3539:$H$3547,$A$3557:$H$3565,$A$3586:$H$3594,$A$3604:$H$3612,$A$3633:$H$3641,$A$3651:$H$3659,$A$3680:$H$3688,$A$3698:$H$3706,$A$3727:$H$3735,$A$3745:$H$3753,$A$3774:$H$3782,$A$3792:$H$3800,$A$3821:$H$3829,$A$3839:$H$3847,$A$3868:$H$3876,$A$3886:$H$3894,$A$3915:$H$3923,$A$3933:$H$3941,$A$3962:$H$3970,$A$3980:$H$3988,$A$4009:$H$4017,$A$4027:$H$4035,$A$4056:$H$4064,$A$4074:$H$4082,$A$4103:$H$4111,$A$4121:$H$4129,$A$4150:$H$4158,$A$4168:$H$4176,$A$4197:$H$4205,$A$4215:$H$4223,$A$4244:$H$4252,$A$4262:$H$4270,$A$4291:$H$4299,$A$4309:$H$4317,$A$4338:$H$4346,$A$4356:$H$4364,$A$4385:$H$4393,$A$4403:$H$4411,$A$4432:$H$4440,$A$4450:$H$4458,$A$4479:$H$4487,$A$4497:$H$4505,$A$4526:$H$4534,$A$4544:$H$4552,$A$4573:$H$4581,$A$4591:$H$4599,$A$4620
:$H$4628,$A$4638:$H$4646,$A$4667:$H$4675,$A$4685:$H$4693,$A$4714:$H$4722,$A$4732:$H$4740,$A$4761:$H$4769,$A$4779:$H$4787,$A$4808:$H$4816,$A$4826:$H$4834,$A$4855:$H$4863,$A$4873:$H$4881,$A$4902:$H$4910,$A$4920:$H$4928,$A$4949:$H$4957,$A$4967:$H$4975,$A$4996:$H$5004,$A$5014:$H$5022,$A$5043:$H$5051,$A$5061:$H$5069,$A$5090:$H$5098,$A$5108:$H$5116,$A$5137:$H$5145,$A$5155:$H$5163,$A$5184:$H$5192,$A$5202:$H$5210,$A$5231:$H$5239,$A$5249:$H$5257,$A$5278:$H$5286,$A$5296:$H$5304,$A$5325:$H$5333,$A$5343:$H$5351,$A$5372:$H$5380,$A$5390:$H$5398,$A$5419:$H$5427,$A$5437:$H$5445,$A$5466:$H$5474,$A$5484:$H$5492,$A$5513:$H$5521,$A$5531:$H$5539,$A$5560:$H$5568,$A$5578:$H$5586,$A$5607:$H$5615,$A$5625:$H$5633,$A$5654:$H$5662,$A$5672:$H$5680,$A$5701:$H$5709,$A$5719:$H$5727,$A$5748:$H$5756,$A$5766:$H$5774,$A$5795:$H$5803,$A$5813:$H$5821,$A$5842:$H$5850,$A$5860:$H$5868,$A$5889:$H$5897,$A$5907:$H$5915,$A$5936:$H$5944,$A$5954:$H$5962,$A$5983:$H$5991,$A$6001:$H$6009,$A$6030:$H$6038,$A$6048:$H$6056,$A$6077:$H$6085,$A$6095:$H$6103,$A$612
4:$H$6132,$A$6142:$H$6150,$A$6171:$H$6179,$A$6189:$H$6197,$A$6217:$H$6225,$A$6235:$H$6243,$A$6264:$H$6272,$A$6282:$H$6290,$A$6311:$H$6319,$A$6329:$H$6337,$A$6358:$H$6366,$A$6376:$H$6384,$A$6405:$H$6413,$A$6423:$H$6431,$A$6452:$H$6460,$A$6470:$H$6478,$A$6499:$H$6507,$A$6517:$H$6525,$A$6546:$H$6554,$A$6564:$H$6572,$A$6593:$H$6601,$A$6611:$H$6619,$A$6640:$H$6648,$A$6658:$H$6666,$A$6687:$H$6695,$A$6705:$H$6713,$A$6734:$H$6742,$A$6752:$H$6760,$A$6781:$H$6789,$A$6799:$H$6807,$A$6828:$H$6836,$A$6846:$H$6854,$A$6875:$H$6883,$A$6893:$H$6901,$A$6922:$H$6930,$A$6940:$H$6948,$A$6969:$H$6977,$A$6987:$H$6995,$A$7016:$H$7024,$A$7034:$H$7042,$A$7063:$H$7071,$A$7081:$H$7089,$A$7110:$H$7118,$A$7128:$H$7136,$A$7157:$H$7165,$A$7175:$H$7183,$A$7204:$H$7212,$A$7222:$H$7230,$A$7251:$H$7259,$A$7269:$H$7277,$A$7298:$H$7306,$A$7316:$H$7324,$A$7344:$H$7352,$A$7362:$H$7370,$A$7391:$H$7399,$A$7409:$H$7417,$A$7438:$H$7446,$A$7456:$H$7464,$A$7485:$H$7493,$A$7503:$H$7511,$A$7532:$H$7540,$A$7550:$H$7558,$A$7579:$H$7587,$A$7597:$H$7605,$A$76
26:$H$7634,$A$7644:$H$7652,$A$7673:$H$7681,$A$7691:$H$7699,$A$7720:$H$7728,$A$7738:$H$7746,$A$7767:$H$7775,$A$7785:$H$7793,$A$7814:$H$7822,$A$7832:$H$7840,$A$7861:$H$7869,$A$7879:$H$7887,$A$7907:$H$7915,$A$7925:$H$7933,$A$7954:$H$7962,$A$7972:$H$7980,$A$8001:$H$8009,$A$8019:$H$8027,$A$8048:$H$8056,$A$8066:$H$8074,$A$8095:$H$8103,$A$8113:$H$8121,$A$8142:$H$8150,$A$8160:$H$8168,$A$8189:$H$8197,$A$8207:$H$8215,$A$8236:$H$8244,$A$8254:$H$8262,$A$8283:$H$8291,$A$8301:$H$8309,$A$8330:$H$8338,$A$8348:$H$8356,$A$8377:$H$8385,$A$8395:$H$8403,$A$8424:$H$8432,$A$8442:$H$8450,$A$8470:$H$8478,$A$8488:$H$8496,$A$8517:$H$8525,$A$8535:$H$8543,$A$8564:$H$8572,$A$8582:$H$8590,$A$8611:$H$8619,$A$8629:$H$8637,$A$8658:$H$8666,$A$8676:$H$8684,$A$8705:$H$8713,$A$8723:$H$8731,$A$8752:$H$8760,$A$8770:$H$8778,$A$8799:$H$8807,$A$8817:$H$8825,$A$8846:$H$8854,$A$8864:$H$8872,$A$8893:$H$8901,$A$8911:$H$8919,$A$8940:$H$8948,$A$8958:$H$8966,$A$8987:$H$8995,$A$9005:$H$9013,$A$9034:$H$9042,$A$9052:$H$9060,$A$9081:$H$9089,$A$9099:$H$9107,$A$9
128:$H$9136,$A$9146:$H$9154,$A$9175:$H$9183,$A$9193:$H$9201,$A$9222:$H$9230,$A$9240:$H$9248,$A$9269:$H$9277,$A$9287:$H$9295,$A$9316:$H$9324,$A$9334:$H$9342,$A$9363:$H$9371,$A$9381:$H$9389,$A$9410:$H$9418,$A$9428:$H$9436,$A$9457:$H$9465,$A$9475:$H$9483,$A$9504:$H$9512,$A$9522:$H$9530,$A$9551:$H$9559,$A$9569:$H$9577,$A$9598:$H$9606,$A$9616:$H$9624,$A$9645:$H$9653,$A$9663:$H$9671,$A$9692:$H$9700,$A$9710:$H$9718,$A$9739:$H$9747,$A$9757:$H$9765,$A$9786:$H$9794,$A$9804:$H$9812,$A$9833:$H$9841,$A$9851:$H$9859,$A$9880:$H$9888,$A$9898:$H$9906,$A$9927:$H$9935,$A$9945:$H$9953,$A$9974:$H$9982,$A$9992:$H$10000,$A$10021:$H$10029,$A$10039:$H$10047,$A$10068:$H$10076,$A$10086:$H$10094,$A$10115:$H$10123,$A$10133:$H$10141
length of signs in Adr: 6833
```

RTE raised is 1004 like stated by kalilMe earlier on.

Holger


----------



## KalilMe (Wednesday at 9:55 AM)

@kvsrinivasamurthy
there  is  problem  for  all  of  your  codes   sorry I  said   that ! 
I've found out latey   because  I  have big  data and  I  don't  expect  showing  this  problem . based  on  your  code  you  don't  specify  the  color  just   you  depend  on  the  highlighted  cell, but  if  there  is  the  cell is  not  highlighted  in  SUMMING  last row  for column H  also  will copy !
BTW  in  last code  gives error mismatch in this  line

```
M = Filter(Evaluate("transpose(IF(Sheet1!B2:B" & Lr & "=""SUMMING"",Row(Sheet1!B2:B" & Lr & "),False))"), False, False)
```
thanks  again


----------



## kvsrinivasamurthy (Wednesday at 10:14 AM)

The error mismatch may be  In column B there is no cell containing "SUMMING".


----------



## kvsrinivasamurthy (Wednesday at 10:43 AM)

Try. This code reads only those ranges For which H cell is not colored (Irrespective of any color) and deletes those ranges.

```
Sub DataColoured3()
Dim col As Long, Lr As Long, T As Long, Ro As Long
Dim M, Adr
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Sheet2").Delete
On Error GoTo 0
Sheets("Sheet1").Copy After:=Sheets("Sheet1")
ActiveSheet.Name = "Sheet2"
Lr = Range("B" & Rows.Count).End(xlUp).Row
col = 16777215
M = Filter(Evaluate("transpose(IF(Sheet2!B2:B" & Lr & "=""SUMMING"",Row(Sheet2!B2:B" & Lr & "),False))"), False, False)

For T = 0 To UBound(M)
If Range("H" & M(T)).Interior.Color = col Then
With Range("H" & M(T)).CurrentRegion
Adr = Adr & "," & .Resize(.Rows.Count + 2).Address
End With
End If
Next T
If Adr <> "" Then Range(Mid(Adr, 2)).Delete Shift:=xlUp
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
```


----------



## KalilMe (Yesterday at 4:05 AM)

@kvsrinivasamurthy 

from  the  first  time  the  code  works   as  what  I  want , but  if  update  data in  sheet1 , then  should  update  data in sheet2  without  any problem  , but  this  is  not  what  happens . it  shows ths  same  problem  as  in post#37  (also copy  not highlighted cells)

after copying  highlighted   data to  sheet2  and  return to  sheet1  to  delete the  color for range For which H , then should update in sheet2  by  delete the  whole  range becomes  no color ,and if   change  range For which H  from not  highlighted to highlighted  range For which H   in sheet1  then should  add to  sheet2  
so  any updating  in sheet1  should also  updating in sheet2 .
should  replace  data in sheet2 every  time  run the  macro .


----------



## KalilMe (Sunday at 4:04 AM)

Hello
I  want  copying   for  each  range  just  contains  higlighted  cell   in column H for  the  last  row (SUMMING) from sheet to another 
source data
Copy of TR.xlsmABCDEFGH1CODE2FR-003ITEMDATEGOODSTYPEPRQTYUNITTOTAL4101/01/2021BANANAFOPL200.0012.002400.005207/01/2021BANANAFOPL450.0012.005400.006308/01/2021BANANAFOPL500.0019.579785.717414/01/2021BANANAFOPL800.0025.3620285.718515/01/2021BANANAFOPL850.0026.3222373.219SUMMING2800.0060244.64101112CODE13FR-0114ITEMDATEGOODSTYPEPRQTYUNITTOTAL15102/01/2021APPLEFRPPL100.0014.001400.0016209/01/2021APPLEFRPPL550.0020.5411294.6417316/01/2021APPLEFRPPL900.0027.2924557.1418SUMMING1550.0037251.79192021CODE22FR-0223ITEMDATEGOODSTYPEPRQTYUNITTOTAL24103/01/2021PEACHFRLLP300.0015.004500.0025210/01/2021PEACHFRLLP600.0021.5012900.0026317/01/2021PEACHFRLLP950.0028.2526837.5027SUMMING1850.0044237.50282930CODE31FR-0332ITEMDATEGOODSTYPEPRQTYUNITTOTAL33104/01/2021PEARFRTTL300.0012.003600.0034211/01/2021PEARFRTTL650.0022.4614601.7935318/01/2021BANANAFOPL1000.0029.2129214.2936SUMMING1950.0047416.07373839CODE40FR-0441ITEMDATEGOODSTYPEPRQTYUNITTOTAL42105/01/2021STRWBERRAYFRMML350.0020.007000.0043212/01/2021STRWBERRAYFRMML700.0023.4316400.0044319/01/2021APPLEFRPPL1050.0030.1831687.5045SUMMING2100.0055087.50RETSEL

result  like  this 
Copy of TR.xlsmABCDEFGH1CODE2FR-003ITEMDATEGOODSTYPEPRQTYUNITTOTAL4101/01/2021BANANAFOPL200.0012.002400.005207/01/2021BANANAFOPL450.0012.005400.006308/01/2021BANANAFOPL500.0019.579785.717414/01/2021BANANAFOPL800.0025.3620285.718515/01/2021BANANAFOPL850.0026.3222373.219SUMMING2800.0060244.64101112CODE13FR-0214ITEMDATEGOODSTYPEPRQTYUNITTOTAL15103/01/2021PEACHFRLLP300.0015.004500.0016210/01/2021PEACHFRLLP600.0021.5012900.0017317/01/2021PEACHFRLLP950.0028.2526837.5018SUMMING1850.0044237.50192021CODE22FR-0423ITEMDATEGOODSTYPEPRQTYUNITTOTAL24105/01/2021STRWBERRAYFRMML350.0020.007000.0025212/01/2021STRWBERRAYFRMML700.0023.4316400.0026319/01/2021APPLEFRPPL1050.0030.1831687.5027SUMMING2100.0055087.50result

*note: *the data are increasable and changeable in sheet RETSEL


----------



## kvsrinivasamurthy (Yesterday at 4:39 AM)

Use the latest code.
After updating the data in sheet1 run macro once again. Sheet2 will  have all the required from Sheet1.
During the process of macro run what is happening do not worry. See only final result.
If problem is not solved  upload  a sample file. showing the result.


----------



## kvsrinivasamurthy (Yesterday at 5:17 AM)

Try this code. Names of sheets changed to RETSEL and result.

```
Sub DataColoured3()
Dim col As Long, Lr As Long, T As Long, Ro As Long
Dim M, Adr
Dim Sh1, Sh2 As Worksheet
Set Sh1 = Sheets("RETSEL"): Set Sh2 = Sheets("result")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Sh2.Delete
On Error GoTo 0
Sh1.Copy After:=Sh1
ActiveSheet.Name = "result"
Lr = Range("B" & Rows.Count).End(xlUp).Row
col = 16777215
M = Filter(Evaluate("transpose(IF(RETSEL!B2:B" & Lr & "=""SUMMING"",Row(RETSEL!B2:B" & Lr & "),False))"), False, False)

For T = 0 To UBound(M)
If Range("H" & M(T)).Interior.Color = col Then
With Range("H" & M(T)).CurrentRegion
Adr = Adr & "," & .Resize(.Rows.Count + 2).Address
End With
End If
Next T
If Adr <> "" Then Range(Mid(Adr, 2)).Delete Shift:=xlUp
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
```


----------



## kvsrinivasamurthy (Yesterday at 5:22 AM)

Try this code also.

```
Sub DataColoured3()
Dim col As Long, Lr As Long, T As Long, Ro As Long
Dim M, Adr
Dim Sh1, Sh2 As Worksheet
Set Sh1 = Sheets("RETSEL"): Set Sh2 = Sheets("result")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Sh2.Delete
On Error GoTo 0
Sh1.Copy After:=Sh1
ActiveSheet.Name = "result"
Lr = Range("B" & Rows.Count).End(xlUp).Row
col = 16777215
M = Filter(Evaluate("transpose(IF(RETSEL!B2:B" & Lr & "=""SUMMING"",Row(RETSEL!B2:B" & Lr & "),False))"), False, False)

For T = UBound(M) To 0 Step -1
If Range("H" & M(T)).Interior.Color = col Then
With Range("H" & M(T)).CurrentRegion
.Resize(.Rows.Count + 2).Delete Shift:=xlUp
End With
End If
Next T
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
```


----------



## HaHoBe (Yesterday at 5:56 AM)

Hi kvsrinivasamurthy,

Sheet _RETSEL_ on my sample workbook holds data up to row 10145.

#42 still will raise the very same error 1004 caused by Adr, breaking the code so no time is available.

#43 will run, time is 18,828125 sec (the times listed in #14 are based on the same data set but all codes keep sheet _result_ not delete and copy data _Sheet2/resul_t and these are all close to 4 sec).

Again: all codes are run for the same data sheet (no matter how it is called): I wonder what I am doing wrong as your code was labelled to be the fastest of all by KalilMe.

Maybe you should update your userprofile. 

Holger


----------



## Peter_SSs (Yesterday at 5:57 AM)

I tested with about 4,500 rows and this was about 5 times faster than the post #43 code.
From what I can tell the results are the same.


```
Sub Copy_Blocks()
  Dim a As Variant
  Dim nc As Long, j As Long, rws As Long
  Dim rA As Range
  
  Dim tm As Double
  tm = Timer
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  On Error Resume Next
  Sheets("result").Delete
  On Error Resume Next
  Application.DisplayAlerts = True
  Sheets.Add(After:=Sheets("RETSEL")).Name = "result"
  With Sheets("RETSEL")
    nc = .Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    ReDim a(1 To .Range("E" & Rows.Count).End(xlUp).Row + 3, 1 To 1)
    For Each rA In .Range("E1", .Range("E" & Rows.Count).End(xlUp)).SpecialCells(xlConstants).Areas
      rws = rA.Rows.Count + 3
      If Not rA.Cells(rws - 2, 4).Interior.Color = 16777215 Then
        For j = rA.Row To rA.Row + rws - 1
          a(j, 1) = 1
        Next j
      End If
    Next rA
    With .Cells(1, nc).Resize(UBound(a))
      .Value = a
      .SpecialCells(xlConstants).EntireRow.Copy Destination:=Sheets("result").Range("A1")
      .ClearContents
    End With
    Sheets("result").Cells(1, nc).Resize(UBound(a)).ClearContents
    Sheets("result").UsedRange.EntireColumn.AutoFit
  End With
  Application.ScreenUpdating = True
  MsgBox Format(Timer - tm, "0.00")
End Sub
```


----------



## KalilMe (Yesterday at 1:49 PM)

@kvsrinivasamurthy  based on post#43  all  of  thing  are  ok and  I've  found  my  mistake .
your  code is  really fast 
thanks  so much .


----------



## KalilMe (Yesterday at 2:04 PM)

> I tested with about 4,500 rows and this was about 5 times faster than the post #43 code.


are  you  sure?
I'm really  surprised from that !!
in reality  the  code in post#43 is  faster  than code in post #45
I  run the  macro  about  more than  10 times  for each code 
code in post#43  gives  from 0.110 to 0.120
 code in post #45 gives  from 0.200 to 0.220
In fact, you have a preference with the code compared to the code in post#43, because it copies without specifying where a SUMMING word is located, unlike the code in post #43 . If it was an error in its location, a problem with the code would occur. For this reason, I chose the mark for your solution. As for the speed, for me, it is not a big difference.
thanks  Peter  for  your  solution


----------



## HaHoBe (Yesterday at 2:29 PM)

Hi KalilMe,

I was cuious and developped a workbook where all codes from this thread are covered and started from one procedure so that all work on the same dataset. I can assure you that Peter_SSs on this dataset is a lot faster than the praised code from #43.


```
Sub StartAllMacrosFormHere()

  Const cblnRun As Boolean = False

  dream_02
  MrE_1226327_05
  CopyData_07
  MrE_1226327_08
  MrE_1226327_17
  DataColoured_18
  If cblnRun Then DataColoured_23   'msgbox to avoid RTE for adding Sheet
  If cblnRun Then DataColoured_24   'error for this setup
  MrE_1226327_26
  If cblnRun Then DataColoured_27   'error for this setup
  If cblnRun Then DataColoured_33   'error for this setup
  If cblnRun Then DataColoured_35   'error for this setup
  If cblnRun Then DataColoured_39   'error for this setup
  If cblnRun Then DataColoured_42   'error for this setup
  DataColoured_43
  Copy_Blocks_45
 
End Sub
```

Result from the immediate window_


```
2,5859375 sec for procedure 'dream_02' by shinigamilight
1,9609375 sec for procedure 'MrE_1226327_05' by HaHoBe
2,46875 sec for procedure 'CopyData_07' by mumps
2,5390625 sec for procedure 'MrE_1226327_08' by HaHoBe
1 sec for procedure 'MrE_1226327_17' by HaHoBe - only copying values
2,3984375 sec for procedure 'DataColoured_18' by kvsrinivasamurthy - please check for areas copied to result
0,515625 sec for procedure 'MrE_1226327_26' by HaHoBes
12,359375 sec for procedure 'DataColoured_43' by kvsrinivasamurthy
1,43 sec for procedure 'Copy_Blocks_45' by Peter_SSs
```

Workbook maybe downloaded here, Size is 554 KB. Dataset goes up to Row 9934. Macros need to get started from IDE/MacroBox.

Added Code in Workbook_Open/DieseArbeitsmappe:


```
Private Sub Workbook_Open()
  With tblRemarks
    .Move After:=Worksheets(Worksheets.Count)
    .Activate
  End With
End Sub
```

Waiting for your results when running _StartAllMacrosFormHere _

Ciao,
Holger


----------



## HaHoBe (Yesterday at 2:50 PM)

Update:

the formatting of time for PeterSSs wasn't correct, I altered the code to


```
Application.ScreenUpdating = True
  Dim tmEnd As Double
  tmEnd = Timer
  Debug.Print tmEnd - tm & " sec for procedure 'Copy_Blocks_45' by Peter_SSs"
```

and got 


```
0,390625 sec for procedure 'Copy_Blocks_45' by Peter_SSs
0,421875 sec for procedure 'Copy_Blocks_45' by Peter_SSs
0,390625 sec for procedure 'Copy_Blocks_45' by Peter_SSs
```

Holger


----------



## KalilMe (Yesterday at 2:59 PM)

@HaHoBe

you're  right  about  the  speed for  your  file .
in  reality I  tested  just post #26,43,45 (theses  solve  my  requiremnts)
despite  of   you  don't  use   borders  and  some  colors   like  my  file  contains  colors   not just   the  headers  also  the  lastrow  contains  color  , even if  that  my  testing  is  faster  than  you . this  is  strange!!
just  guess , is  the  reason  from  using  formulas  in  some  ranges  make  slow  the  codes as  you  use that ?
actually  I  have not formulas  at  all on  my  file  or  OP . and  I  tested  for  8000 rows  for  all  of  the  codes .


----------



## KalilMe (Sunday at 4:04 AM)

Hello
I  want  copying   for  each  range  just  contains  higlighted  cell   in column H for  the  last  row (SUMMING) from sheet to another 
source data
Copy of TR.xlsmABCDEFGH1CODE2FR-003ITEMDATEGOODSTYPEPRQTYUNITTOTAL4101/01/2021BANANAFOPL200.0012.002400.005207/01/2021BANANAFOPL450.0012.005400.006308/01/2021BANANAFOPL500.0019.579785.717414/01/2021BANANAFOPL800.0025.3620285.718515/01/2021BANANAFOPL850.0026.3222373.219SUMMING2800.0060244.64101112CODE13FR-0114ITEMDATEGOODSTYPEPRQTYUNITTOTAL15102/01/2021APPLEFRPPL100.0014.001400.0016209/01/2021APPLEFRPPL550.0020.5411294.6417316/01/2021APPLEFRPPL900.0027.2924557.1418SUMMING1550.0037251.79192021CODE22FR-0223ITEMDATEGOODSTYPEPRQTYUNITTOTAL24103/01/2021PEACHFRLLP300.0015.004500.0025210/01/2021PEACHFRLLP600.0021.5012900.0026317/01/2021PEACHFRLLP950.0028.2526837.5027SUMMING1850.0044237.50282930CODE31FR-0332ITEMDATEGOODSTYPEPRQTYUNITTOTAL33104/01/2021PEARFRTTL300.0012.003600.0034211/01/2021PEARFRTTL650.0022.4614601.7935318/01/2021BANANAFOPL1000.0029.2129214.2936SUMMING1950.0047416.07373839CODE40FR-0441ITEMDATEGOODSTYPEPRQTYUNITTOTAL42105/01/2021STRWBERRAYFRMML350.0020.007000.0043212/01/2021STRWBERRAYFRMML700.0023.4316400.0044319/01/2021APPLEFRPPL1050.0030.1831687.5045SUMMING2100.0055087.50RETSEL

result  like  this 
Copy of TR.xlsmABCDEFGH1CODE2FR-003ITEMDATEGOODSTYPEPRQTYUNITTOTAL4101/01/2021BANANAFOPL200.0012.002400.005207/01/2021BANANAFOPL450.0012.005400.006308/01/2021BANANAFOPL500.0019.579785.717414/01/2021BANANAFOPL800.0025.3620285.718515/01/2021BANANAFOPL850.0026.3222373.219SUMMING2800.0060244.64101112CODE13FR-0214ITEMDATEGOODSTYPEPRQTYUNITTOTAL15103/01/2021PEACHFRLLP300.0015.004500.0016210/01/2021PEACHFRLLP600.0021.5012900.0017317/01/2021PEACHFRLLP950.0028.2526837.5018SUMMING1850.0044237.50192021CODE22FR-0423ITEMDATEGOODSTYPEPRQTYUNITTOTAL24105/01/2021STRWBERRAYFRMML350.0020.007000.0025212/01/2021STRWBERRAYFRMML700.0023.4316400.0026319/01/2021APPLEFRPPL1050.0030.1831687.5027SUMMING2100.0055087.50result

*note: *the data are increasable and changeable in sheet RETSEL


----------



## Peter_SSs (Yesterday at 8:22 PM)

HaHoBe said:


> Waiting for your results when running _StartAllMacrosFormHere_


I don't know what it is, but seems to be something funny happening with that _StartAllMacrosFormHere_ procedure.
I went through all the individual procedures and added a line to write the timer results (number only) to the Remarks sheet col M immediately after the Debug.Print line and then ran the StartAllMacrosFormHere procedure.
I manually moved those results from col M to col L and then went back and ran each of the procedures individually, still with the results going to 'Remarks' col M
Below are my results. You wouldn't expect the results to be identical but it looks like there could be something unusual with the second procedure and something definitely unusual with the final one.

Copy Ranges Test WB AnySheet230112.xlsmLMN1StartAllMacrosFormHereIndividual Procedures22.232.38106.73%31.871.0656.68%42.462.3394.72%52.442.3696.72%60.480.59122.92%72.192.23101.83%80.230.26113.04%98.517.588.13%102.110.199.00%RemarksCell FormulasRangeFormulaN2:N10N2=M2/L2


----------



## HaHoBe (Today at 6:01 AM)

Hi PeterSSs,

all I can do is confirm what you point out.

Running your code alone brings up

```
0,44140625 sec for procedure 'Copy_Blocks_45' by Peter_SSs
0,375 sec for procedure 'Copy_Blocks_45' by Peter_SSs
0,44140625 sec for procedure 'Copy_Blocks_45' by Peter_SSs
```
while last position in caller (all kvsrinivasamurthy codes except DataColoured_43 deactivated)

```
1,5390625 sec for procedure 'Copy_Blocks_45' by Peter_SSs
```
Running only these two codes from caller:

```
0,51953125 sec for procedure 'MrE_1226327_26' by HaHoBe
0,36328125 sec for procedure 'Copy_Blocks_45' by Peter_SSs
```

First of all I can only state that your code is the fastest provided no matter what the lines in the Immediate Window or on the sheet say. And times (if less than one second) should be monitored by something else than Timer (but I wonder if that would be worth altering the code if available when you have the feeling the code is doing the job properly and fast enough for you).

Holger


----------



## Peter_SSs (Today at 6:14 AM)

HaHoBe said:


> but I wonder if that would be worth altering the code if available when you have the feeling the code is doing the job properly and fast enough for you


I agree. Use the code that you are most comfortable with if you are happy with the accuracy and speed. 

Thanks for double-checking the different timings though.


----------

