PDA

View Full Version : Copy calculated data ranges in Sheet2 O:O to Sheet1 offset column block areas in C:C



errolw98
12-04-2018, 07:58 PM
I apologize for being such a Noob but that's what I am and I need to do some advanced things with VBA and Excel. I look to this community as the helping experts and appreciate any help I get. Thanks for reading my post.


This seems like it would be an easy thing but I am struggling to get the desired results. I have searched the internet for days to solve this without finding the solution. I really need some help with this. But I have made some progress.


In Sheet2, I have a simple data stream of values coming in from a connection to a continually updating value table. Once the values have come they do not normally change.

In Sheet2 column "O:O" contains results from math performed on the incoming data table. This is simulated in the linked sheet. The basic result is a number with "0.000" format with the exception of two occasional text values. "Stop" and "Station". These text strings can be anywhere in O:O and are always the same text.

Each time a new value shows up in the table, the resulting values from the first calculation row in Column "O:O" down to and including the first text value need to be copied to a block range in Sheet1 starting at cell C21, named "Run_1_Start".

Once that has been done the next and subsequent calculated numeric values need to be copied to a new block range starting at cell C35, Named "Run_2_Start", until the second instance of text value. The process repeats with the each data sample copied to Next block range starting Cell.
Occasionally a block of data will spill over into the next so a function of looking at the next Sheet1 start cell in line to determine if it contains data then go to the next start cell would be beneficial. That can be handled later after the main goal is accomplished.

I can get and post the cell address of each text value in Sheet2 P:P adjacent to its O:O cell with the first code. Might be able to help define a range.
With the second code I can reliably paste the data without duplicates where it needs to go. I have manually assigned worksheet named ranges to the calculated data in Sheet2 which needs to be done automatically in VBA if it is to be used.

I have also manually assigned named cells at the start of each Sheet1 block to be pasted to which can remain static. When using a Named Range in Sheet1 i.e "Block1", caused the anomaly of if the copied data from Sheet2 was 7 cells, or half of the Sheet1 named range of 14 cells it would paste the same data twice, filling up the named range in Sheet1 with duplicates.

If I could use VBA to name the range in Sheet2, "Run_1" from the start, O2, to each new data result each time it comes in and is calculated to a value in O:O down to the occurrence of a Text value, Pasting the results to a named cell in Sheet1 "Run_1_Start" cell. Have the first Named range in Sheet2 remain from O2, to including the first text string, then start naming the next numeric value/s in Sheet2 O:O "Run_2" pasting that to down to and including the next occurrence of a Text value to Sheet1 "Run_2_Start" cell. This will eventually span a total of around 20 data blocks in Sheet1 so needs to be scalable

The addresses in Sheet2 P:P and all pasted data in Sheet1 C21:C can be erased to watch the macros I have work in the linked sheet bellow. Any Help would be greatly appreciated.

Thanks In Advance.

23346

Returns cell address of searched text values





Sub GetCellAddy()
'Find all instances of "Stop" and "Station" in Sheet2 Column O:O then paste the cell name in adjacent cell in ColumnP:P
'Stop Updating, Alerts, Events and Calcs for speed and fewer VBA Crashes
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Worksheets(2).Select
row_count = 220 ' the number of rows in your range
For r = 1 To row_count
If Cells(r, 15) = "Stop" Then
Cells(r, 16) = Cells(r, 15).Address
End If
Next r
For r = 1 To row_count
If Cells(r, 15) = "Station" Then
Cells(r, 16) = Cells(r, 15).Address
End If
Next r
'Restart Updating, Alerts, Events and Calcs after code completes
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub


Copies and pastes values appropriately but requires source range to be manually Named. This needs an automatic solution.


Sub PasteNamedRange()
'This could work if I can write code to Name the range fron start to first "Stop" then fron the cell below first "Stop" to next "Stop" etc.


'Stop Updating, Alerts, Events and Calcs for speed and fewer VBA Crashes.
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual


' Run the Error handler "ErrHandler" when an error occurs.
On Error GoTo Errhandler


Worksheets(2).Range("Run_1").Copy
Worksheets(1).Range("Run_1_Start").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False 'Problem: when a range that is half of the Named Block size I paste to i.e.. Block1 on Sheet1, it pastes it twice.
Application.CutCopyMode = False
Worksheets(2).Range("Run_2").Copy
Worksheets(1).Range("Run_2_Start").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets(2).Range("Run_3").Copy
Worksheets(1).Range("Run_3_Start").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Worksheets(2).Range("Run_4").Copy
Worksheets(1).Range("Run_4_Start").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets(2).Range("Run_5").Copy
Worksheets(1).Range("Run_5_Start").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets(2).Range("Run_6").Copy
Worksheets(1).Range("Run_6_Start").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

'Put more copy lines here if I learn code to name ranges in Sheet2 based on the above search that works well


'Restart Updating, Alerts, Events and Calcs after code completes.
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic


Worksheets(2).Select
Range("A1").Select
Application.CutCopyMode = False
Worksheets(1).Select
Range("A1").Select
Application.CutCopyMode = False


Errhandler:
Worksheets(2).Select
Range("A1").Select
Application.CutCopyMode = False
Worksheets(1).Select
Range("A1").Select
Application.CutCopyMode = False
'Restart Updating, Alerts, Events and Calcs after code Error.
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Exit Sub

'Restart Updating, Alerts, Events and Calcs after code Error.
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic


End Sub

大灰狼1976
12-06-2018, 08:55 PM
Hi errolw98
I am not good at English,But I tried to do it.

Private Sub test()
Dim arr, arr1(), r1&, r2&, rng As Range, i&, r&, blk&
With Sheets(2)
r1 = .[o1].End(4).Row
r2 = .[o1048576].End(3).Row
arr = .Range(.Cells(r1, "o"), .Cells(r2, "o"))
End With
For i = 1 To UBound(arr)
r = r + 1
ReDim Preserve arr1(1 To (blk + 1) * 14)
arr1(blk + r) = arr(i, 1)
If arr(i, 1) = "Stop" Then blk = blk + 14: r = 0
Next i
Sheets(1).[c21].Resize(UBound(arr1)) = Application.Transpose(arr1)
End Sub

大灰狼1976
12-06-2018, 09:27 PM
I'm sorry there was a mistake just now.

Private Sub test()
Dim arr, arr1(), r1&, r2&, i&, r&, blk&
With Sheets(2)
r1 = .[o1].End(4).Row
r2 = .[o1048576].End(3).Row
arr = .Range(.Cells(r1, "o"), .Cells(r2, "o"))
End With
ReDim arr1(1 To 14)
For i = 1 To UBound(arr)
r = r + 1
arr1(r) = arr(i, 1)
If arr(i, 1) = "Stop" Then
blk = blk + 14
r = blk
ReDim Preserve arr1(1 To blk + 14)
End If
Next i
Sheets(1).[c21].Resize(UBound(arr1)) = Application.Transpose(arr1)
End Sub

errolw98
12-06-2018, 10:56 PM
大灰狼1976
Thanks Very much for looking at my project.
This is a Very Promising piece of code in a different format than I am used to seeing. I gave it a short trial and like I said it is very promising.
I will give it some bigger testing tomorrow and get back to you.
Again Thanks very much!


I'm sorry there was a mistake just now.

Private Sub test()
Dim arr, arr1(), r1&, r2&, i&, r&, blk&
With Sheets(2)
r1 = .[o1].End(4).Row
r2 = .[o1048576].End(3).Row
arr = .Range(.Cells(r1, "o"), .Cells(r2, "o"))
End With
ReDim arr1(1 To 14)
For i = 1 To UBound(arr)
r = r + 1
arr1(r) = arr(i, 1)
If arr(i, 1) = "Stop" Then
blk = blk + 14
r = blk
ReDim Preserve arr1(1 To blk + 14)
End If
Next i
Sheets(1).[c21].Resize(UBound(arr1)) = Application.Transpose(arr1)
End Sub

errolw98
12-07-2018, 01:20 PM
大灰狼1976
This code is brilliant. Thanks so much for this. Super lightweight and fast.
I wish I knew how it worked.
Works perfectly on my test document but gives a Run-time error '9': Subscript out of range on this line "arr1(r) = arr(i, 1)" when I try it in my real document. Not sure what is going on.
Sheets(1) and Sheets(2) are in the correct location and name. There are other sheets in the real workbook.
Like I said, It is brilliant on my test workbook. Now I want it to work in the real workbook. I wish I knew how it works. Also would like to add a second "Text" but I could do that with a second instance of the code maybe or make the results all say "Stop" where needed.
***EDIT***
I know why the code is failing now but I don't know how to fix it. It sees more than 14 instances of anything without the searched text and sets the same error. This threw me off because in the results in Column O:O on the real workbook there are not instances of more than 14 calculated values without a text value. However the O:O Column is filled with hundreds of =IF([cell]="","",[do this]) formulas that I need. How can I get this code to ignore formulas and only solve with values?
This code is Genius. Would be perfect if that could happen.

errolw98
12-07-2018, 07:21 PM
大灰狼1976
I have attached a version of my workbook with most of what I found documented. I love the macro. just wish it would work. Even a copy paste of values to P:P column wont work if there are more than 14 formulas after the last "Stop" instance. The copy paste must put some marker in the empty pasted cell. If you could get this to ignore O:O column formulas, it would be magic.

大灰狼1976
12-09-2018, 05:55 PM
Hi errolw98!
I'm a little busy in the morning(because of jet lag). I'll take a look when I have time.

大灰狼1976
12-09-2018, 08:20 PM
I'm not good at English, but i try to do it. (English is difficult)
Please refer to the attached, and I commented on the code.

大灰狼1976
12-09-2018, 08:26 PM
Now you can manual entry of keyword, but i'm sorry no error handling.

errolw98
12-10-2018, 02:00 PM
大灰狼1976,
Thank you for the help and the code comments. I like the Manual Keyword Input Box as well. I found a built in way around last row error by using a tick box in the data connection creation that says "fill down adjacent formulas" that way I don't have to have hundreds of formulas in the r2 =column. I think I have also found a way to minimize the over 14 entry error potential by changing the block size to 20 on the Sheet(1) side and your code to change I am seeing that anywhere it says 14, change to 20. I do love the speed and lightweight of this code.
Thank you so much.

大灰狼1976
12-13-2018, 08:27 PM
errolw98,
no thanks, I'm glad you can find your own way.
If there are other problems later, I will try to help if I could do it.