Transfer specific columns if a condition is met

menajaro
2StarLounger
Posts: 168
Joined: 24 Jan 2019, 10:58

Transfer specific columns if a condition is met

Post by menajaro »

Hello everyone
Mr. Doc.AElstein has already helped me in that code Which Transfer specific columns from Main sheet into two other sheets
depending on a column k as follows :
If "positive" exist in Column K ... columns will be transferred A,D,F & columns from Z to column AT in consultant doctor sheet.
Otherwise, columns will be transferred A,D,F & columns from Z to column AT in Specialist Doctor sheet.
It works very well And also very very fast but I want to be able to add some codes to insert Seven rows after each 27 rows.
One of these Seven rows would contain the totals for rows.Then leave five empty rows without borders to add some Text strings
Such as ( First signature - Second signature - third signature - Fourth signature - Fifth signature ). below the tables
and at the end there will be one row For the previous total.
Hope this will be clear enough when you peruse Desired output file
Any help in the correct direction is appreciated. Thank you in advance for your help.
You do not have the required permissions to view the files attached to this post.

User avatar
Doc.AElstein
5StarLounger
Posts: 1149
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Transfer specific columns if a condition is met

Post by Doc.AElstein »

Hello menajaro,
I think the modifications to the existing macro to get what you want may be not too difficult, because
_a) your data is quite simply well structured
_b) by a lucky coincidence the way I wrote that existing macro allows us to modify the “vertical row indicie” array, Rws() , quite easily to get those extra in between rows. It needs just a simple bit of maths which I have done somewhere before, I think. I will try to find time to dig out that stuff over the next day or two…

But I think the additions to the macro necessary to get the text and formulas in the extra rows will slow the macro down considerably. I can’t see anyway to do what you want to do and maintain the good speed. I think you will considerably lose the good speed of the current macro. I can’t initially see any way to overcome this large degradation in speed performance

But if you want me to attempt a macro anyway, then I have a couple of questions / requests

_1) can you live without the merged cells , at least initially. at “The total” and “Previous total
It might be possible to incorporate merged cells, but often they mess up VBA coding, so I would like to avoid having them , if that’s possible.
_2) Is it possible to have a spare worksheet in your file, like the TempSht in the returned uploaded file

Alan
You do not have the required permissions to view the files attached to this post.
\ -_- / :heavy:

menajaro
2StarLounger
Posts: 168
Joined: 24 Jan 2019, 10:58

Re: Transfer specific columns if a condition is met

Post by menajaro »

Hello Alan,
Thanks a lot for your reply and take your time .. I am not in hurry
1- Yes my dear friend I can live without the merged cells, no problem with that
2- I have updated the example attached Because I didn't activate the macro button nothing more nothing less
rest assured... there is no degradation in speed performance because the original file does not contain any formulas
Thank you so much for all your help. Have a nice day!

User avatar
Doc.AElstein
5StarLounger
Posts: 1149
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Transfer specific columns if a condition is met

Post by Doc.AElstein »

Hi
_1) No merge cells. Good!
_2) I am afraid I do understand what you are saying there, in your reply 2-
I am not sure if you understood my second question/request. My question is if your workbook can contain an extra worksheet, like the TempSht example that I have made in the returned uploaded file, here, ExampleTuesdayxlsm.xlsm
( This temporary worksheet can be deleted later , if desired).
( This temporary worksheet will be like a pattern for me to copy the formats from, that’s all.
But this worksheet will always need to be present in all your files before the macro is run. Think of it as a blank sheet, which will be copied, and on which the data will be placed by the macro)

If you still don’t understand what I am asking, then don’t worry about it, I will post some solutions when I have time and we can take it from there…( I may be away for a day or two just now )

Alan
You do not have the required permissions to view the files attached to this post.
\ -_- / :heavy:

menajaro
2StarLounger
Posts: 168
Joined: 24 Jan 2019, 10:58

Re: Transfer specific columns if a condition is met

Post by menajaro »

Hello Alan,
I believe I misunderstood your question ..My apologies for that!
My workbook does not contain extra worksheets like the TempSht
Do as you like... It,s up to you .. You are such a nice person and i respect for your kind time and help. Have a nice time

User avatar
Doc.AElstein
5StarLounger
Posts: 1149
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Transfer specific columns if a condition is met

Post by Doc.AElstein »

Hi
I have made an initial macro for you to consider, Solution1.
For now, I have limited it to just doing the solution for worksheet "consultant doctor"
I have done this because am expecting that the macro may not be in the final form you will want , so there is no point in me adding the coding for worksheet "Specialist Doctor" , since the extra required coding is almost just a duplicate of the coding required for worksheet "consultant doctor"

Solution1 Explanation Summary
There are broadly speaking two parts to the modifications that you are seeking.
_Part A)
We need to break a string of indices, say shortened for explanation, like …_
Rws()={1,2,4,7,8,9,11,14,16,18,20}
_... to like
Rws()={1,2,4,7,111,111,111,8,9,11,14,111,111,111,16,18,20}
That above is just a shortened example to try to explain to you what I am doing. There, in that simplified example, after every 4 rows we are adding some arbitrary spare row indicia, assuming that the row number 111 is empty so can be taken as an extra inserted empty row in our “magic” code line of
arrOut()=Index(Cells, Rws(), Clms())
In your example you want to add 7 empty rows, ( at least initially empty, then 2 may be filled… ) after every 27 rows.
Part A) is the “clever” stuff, that we should be able to do quite efficiently with minimum modification to the original macro

Part B) Adding the text, formulas border formats etc…
Part B) is not really very clever. It can probably be done in hundreds of different ways , all of them tedious and time consuming, both in writing the code and in the final performance. We can try a few different ways to do this , ##but you must bear in mind, that once you start doing things like this to a spreadsheet using VBA, then all good VBA performance gets chucked away out of the window.

Here more detailed explanation
Part A) is not really difficult based on the existing macro that you have.
For part A) ( and also for some parts of Part B) ) we need to get some simple maths ideas…
Your desired output files make it nicely clear what you want and we can pick out a pattern,
34-7 = 27
41-34= 7
68-41=27
75-68=7
102-75=27
109-102=7
136-109=27
Currently with the existing macro , for the first output worksheet, consultant doctor , we would have had 88 rows.
But your new desired results stop at about 136 rows. This is because you want to split the range and add spare rows inbetween…
I am looking at some dynamic way to get 136, that is to say a way to tell me when to stop doing something, based on the existing number of data rows without extra spaces.
Looking at the pattern, consider, 88/27=3.26
How about, (integer(88/27)+1)x27 + (integer(88/27)x7 = 4x27 + 3x7 = 129
This logic is just playing with the idea from looking at your desired results which have 4 ranges of 27 rows and 3 lots of 7 row spaces in between. This is all just playing around with number ideas at this stage, that's all....
The difference between 129 and 136 is due to us starting at row 7 or 8, so somehow somewhere we should be able to take that extra 7 or 8 into the calculation to give us 129+7=136. We could loop , for example, from 0 to 34 in steps of 34 up to 136, (or some variation of that logic - I am just playing around with number ideas at this stage, that's all...).... 34 comes from 27+7 and is the "length" of something that repeats. The start number will always be the same and the other values in any looping are what we are determining with some variation or other of those bits of maths ideas
There may need to be some tweaking of those numbers to make sure things start and stop exactly as we want them to
The final figures I used in my calculations in my first offering were partly based on trial and error, so they may not be the most efficient formulas and calculations: Maths is not my strong subject! I think they are doing the data range split / segmentation correctly, but I leave it to you to do all the checking..
So that is the clever part, actually done quite simply. In this first attempt I have used string manipulation , that just requires a few simple code lines.

Part B)
I expect you may want us to look further at this.
I doubt that I have this exactly as you want
I have tried to make the macro not too slow and inefficient by using an extra worksheet as a blueprint, worksheet "TempSht". This is what I tried to explain to you in my point _2) , but I don’t think you understood yet.
Never mind, we can have another go later, if you really want to create all the formatting and text every time…. Its pretty stupid to do that from the VBA coding point of view. But maybe you are forced to have to do that?
If it is not acceptable to have a temporary blueprint worksheet, then another workbook , containing that worksheet would be another possibility. (That workbook could contain the macro also, so that your data file could be a .xlsx or .xls file instead)
_.____
You will see that the results from my macros are slightly different to your desired results. This is because the sorting is done after the segmentation, and each segment is sorted. If this is not acceptable then we well probably have to do something in the code section Part A) to sort all the data before any segmentation is done . Once again that is likely to degrade performance considerably.
_.___
One very important thing to note, which I already told you a few times##: Because you are playing around with formatting, copying, pasting and sorting, all the speed advantages of the way I have done macros for you in the past is wasted:
If your final results require a lot of formatting, copying, pasting and sorting, then you might be better off forgetting any macro I ever gave you, and starting from again from scratch using more conventional spreadsheet filtering techniques.

_.____________

My macro is in the next post, and in the attached workbook , and here
I may have time on Sunday to look again at this in detail.


Alan
You do not have the required permissions to view the files attached to this post.
Last edited by Doc.AElstein on 03 Jul 2020, 18:25, edited 12 times in total.
\ -_- / :heavy:

User avatar
Doc.AElstein
5StarLounger
Posts: 1149
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Transfer specific columns if a condition is met

Post by Doc.AElstein »

Macro for last post. See last post for explanations.

Code: Select all

Sub VBAArrayTypeAlternativeToFilterInSegs_Solution1()  '     http://www.eileenslounge.com/viewtopic.php?p=270915#p270915               .......... https://eileenslounge.com/viewtopic.php?p=245238#p245238
Rem Make the two row indicie lists ( string of row indicies seperated witha space )
Dim arrK() As Variant: Let arrK() = Worksheets("Main workbook").Range("K1:K" & Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
Dim strSuc As String, strSpit As String
 Let strSuc = "7": Let strSpit = "7"
 Dim Cnt As Long
    For Cnt = 11 To UBound(arrK(), 1)
        If arrK(Cnt, 1) = "Positive" Then  '/////////
         Let strSuc = strSuc & " " & Cnt
        Else
         Let strSpit = strSpit & " " & Cnt
        End If
    Next Cnt
'Debug.Print strSuc
Rem Part A) modification (via string manipulation)
Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1  to give us the number of row indicies
Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1
    For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
     Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) '           https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
    Next Cnt
' Debug.Print strSuc
Dim clms() As Variant: Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
    For Cnt = 1 To UBound(strRws(), 1) + 1 ': Debug.Print strRws(Cnt - 1)
     Let Rws(Cnt, 1) = strRws(Cnt - 1)
    Next Cnt
Dim arrOut() As Variant: Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms())
 Let Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()
' =====================================================
Rem Part B)
' Header
 Worksheets("TempSht").Range("A7:X7").Copy
 Worksheets("consultant doctor").Range("A7:X7").PasteSpecial Paste:=xlPasteAll    '     https://docs.microsoft.com/en-us/office/vba/api/excel.range.pastespecial       https://docs.microsoft.com/de-de/office/vba/api/excel.xlpastetype
' All formats in one go for each segmant from the temporary blue print worksheet
 Worksheets("TempSht").Range("A8:X41").Copy
 Worksheets("consultant doctor").Range("A8:X" & ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 & "").PasteSpecial Paste:=xlPasteFormats   '
' Formulas
  Worksheets("TempSht").Range("A35:X41").Copy
    For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
     Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).PasteSpecial Paste:=xlFormulas '                  Value = Worksheets("TempSht").Range("A35:X41").Formula
'     Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(7, 24).Sort key1:=Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 2), Header:=False   '   sorting here will clear the clipboard
    Next Cnt
' Sorting
    For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
     Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(7, 24).Sort key1:=Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 2), Header:=False
    Next Cnt

'With Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
'' Let .Value = arrOut()
'.Sort key1:=Worksheets("consultant doctor").Range("C7"), Header:=True
'.Font.Name = "Times New Roman"
'.Font.Size = 13
'.Columns("D:X").NumberFormat = "0.00"
'.EntireColumn.AutoFit
'End With

''Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
' Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
' ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
'    For Cnt = 1 To UBound(strRws(), 1) + 1
'     Let Rws(Cnt, 1) = strRws(Cnt - 1)
'    Next Cnt
' Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms())
'With Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
'Let .Value = arrOut()
''.Sort Key1:=Worksheets("Specialist Doctor").Range("C7"), Header:=True
'.Font.Name = "Times New Roman"
'.Font.Size = 13
'.Columns("D:X").NumberFormat = "0.00"
'.EntireColumn.AutoFit
'End With
End Sub
\ -_- / :heavy:

menajaro
2StarLounger
Posts: 168
Joined: 24 Jan 2019, 10:58

Re: Transfer specific columns if a condition is met

Post by menajaro »

Thank you so much Alan for all your help.You are a true legend. :clapping: :thankyou:
I am going to work on the other sheet to gain some experience.
Thanks again for your support, regards.

User avatar
Doc.AElstein
5StarLounger
Posts: 1149
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Transfer specific columns if a condition is met

Post by Doc.AElstein »

Hi
Here is another solution for you to consider, solution2
This will be a more conventional solution, and probably much easier to understand.
Basically it takes the original macro,
Sub VBAArrayTypeAlternativeToFilter() ' https://eileenslounge.com/viewtopic.php ... 92#p270792
, only very slightly modified, and once that original macro has pasted out the results, it then adds the extra lines and formats , mainly by just Inserting / Pasteing in

I don’t think there is anything at all clever in this solution, other than maybe understanding fully how the Range.Insert Method works: I tend to think of that as a method which makes a space for something to drop into. Understanding how that works when something is in the clipboard when you do it seems to evade most people’s understanding, but it seems quite predictable, so if you understand it then you can use it quite effectively, which is what I try to do in this solution.
So basically the solution involves copying stuff from the TempSht worksheet and then Inserting / Pasteing.

I wrote this solution in two procedures. The first main procedure is almost identical to the very original unmodified macro. The second procedure is Called twice from the main procedure. I don’t see any particular advantages of using called procedures, other than maybe it looks a bit tidier, and in this case, helps illustrate that this solution is basically taking the results from the original macro and then doing stuff to add the extra rows and stuff.
( The original macro also has one extra formatting line added in the two worksheet formatting sections , ( .Borders.LineStyle = xlContinuous ) , )

My macro is in the next post, and in the attached workbook , and here
In this case, it gives you almost exactly your desired results, apart from missing out some borders in the last segment, and possibly some other minor differences that I may have overlooked.

Alan

P.S. I expect you know that coding involving spreadsheet interactions like ( Copy, Paste, Insert etc… ) can sometimes be speeded up by adding the code line of ..._
Application.ScreenUpdating = False
_... somewhere before spreadsheet interactions like ( Copy, Paste, Insert etc… ) are done.
I personally tend to avoid adding those in any macro I give, for the sake of clarity, and also as it makes it easier to develop a macro without that code line in.
So I leave it to you to experiment with adding that code line if you want to see if it speeds up performance. But important is to remember: If you play with that code line, then you must always include a code line of ..._
Application.ScreenUpdating = True
_... in your macro after all the spreadsheet interactions are done. Typically towards the end of the macro is always a good idea to have such a code line. ( The code line won’t error if Screen Updating is already set to True , so it does no harm to include that at the end of any macro just to be on the safe side.)
You do not have the required permissions to view the files attached to this post.
Last edited by Doc.AElstein on 06 Jul 2020, 09:44, edited 7 times in total.
\ -_- / :heavy:

User avatar
Doc.AElstein
5StarLounger
Posts: 1149
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Transfer specific columns if a condition is met

Post by Doc.AElstein »

Macro for last post. See last post for explanations

( The main thing is
Sub DropItIn()
The first macro, Sub VBAArrayTypeAlternativeToFilterToSegs_Solution2() , which is the one that you run, is almost identical to the very first unmodified macro, Sub VBAArrayTypeAlternativeToFilter() ' https://eileenslounge.com/viewtopic.php ... 92#p270792 )

Code: Select all

 Sub VBAArrayTypeAlternativeToFilterToSegs_Solution2() '               https://eileenslounge.com/viewtopic.php?p=271047&sid=d23ea475322d2edf06b70bfeaa95726b#p271047
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = Worksheets("Main workbook").Range("K1:K" & Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Get row indicies for the two output worksheets
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7"
Dim Cnt As Long
    For Cnt = 11 To UBound(arrK(), 1)
        If arrK(Cnt, 1) = "Positive" Then  '/////////
         Let strSuc = strSuc & " " & Cnt
        Else
         Let strSpit = strSpit & " " & Cnt
        End If
    Next Cnt
' First output worksheet
Dim clms() As Variant: Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
    For Cnt = 1 To UBound(strRws(), 1) + 1
     Let Rws(Cnt, 1) = strRws(Cnt - 1)
    Next Cnt
Dim arrOut() As Variant: Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms())
    With Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
    Let .Value = arrOut()
    .Sort Key1:=Worksheets("consultant doctor").Range("C7"), Header:=True
    .Font.Name = "Times New Roman"
    .Font.Size = 13
    .Columns("D:X").NumberFormat = "0.00"
    .EntireColumn.AutoFit
    .Borders.LineStyle = xlContinuous
    End With
' Adding extra rows and stuff for  Worksheets("consultant doctor") ================
'        Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
 Call DropItIn(Worksheets("consultant doctor"), UBound(strRws(), 1) + 1, 8, 34, 27, 7)                                            '  Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
' second output worksheet
'Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
 Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
 ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
    For Cnt = 1 To UBound(strRws(), 1) + 1
     Let Rws(Cnt, 1) = strRws(Cnt - 1)
    Next Cnt
 Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms())
    With Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
     Let .Value = arrOut()
     .Sort Key1:=Worksheets("Specialist Doctor").Range("C7"), Header:=True
     .Font.Name = "Times New Roman"
     .Font.Size = 13
     .Columns("D:X").NumberFormat = "0.00"
     .EntireColumn.AutoFit
     .Borders.LineStyle = xlContinuous
    End With
' Adding extra rows and stuff for  Worksheets("Specialist Doctor") ==================
'        Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
 Call DropItIn(Worksheets("Specialist Doctor"), UBound(strRws(), 1) + 1, 8, 34, 27, 7)                                            '  Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted

End Sub
\ -_- / :heavy:

User avatar
Doc.AElstein
5StarLounger
Posts: 1149
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Transfer specific columns if a condition is met

Post by Doc.AElstein »

This next solution, Solution3, is almost identical to Solution2
The main purpose is just to demonstrate a further possibility, which is to keep your data file as a .xlsx file, ( without any temporary worksheet , TempSht in it ) ,and run the macro from a separate workbook. I will call the macro workbook, Solution3Macros.xlsm That workbook only has one worksheet, the blueprint worksheet, TempSht in it
The data file remains your original uploaded example file , but I have it resaved and uploaded here as Example.xlsx

The procedure, Sub DropItIn3() , is almost the same as , Sub DropItIn(), and the main macro , Sub Solution3_2Workbooks() , is almost the same as Sub VBAArrayTypeAlternativeToFilterToSegs_Solution2()

The main changes are those to make sure we reference the correct workbook

I assume that both workbooks are open

To test this solution3, you should download and open both workbooks, and then run Sub Solution3_2Workbooks() which is in Solution3Macros.xlsm

Here are the macros, which are also in the workbook, Solution3Macros.xlsm and also here

Code: Select all

 Sub Solution3_2Workbooks() '
Rem 1 Worksheets info
Dim WbM As Workbook, WbData As Workbook
 Set WbM = ThisWorkbook: Set WbData = Workbooks("Example.xlsx")
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = WbData.Worksheets("Main workbook").Range("K1:K" & Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Get row indicies for the two output worksheets
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7"
Dim Cnt As Long
    For Cnt = 11 To UBound(arrK(), 1)
        If arrK(Cnt, 1) = "Positive" Then  '/////////
         Let strSuc = strSuc & " " & Cnt
        Else
         Let strSpit = strSpit & " " & Cnt
        End If
    Next Cnt
' First output worksheet
Dim clms() As Variant: Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
    For Cnt = 1 To UBound(strRws(), 1) + 1
     Let Rws(Cnt, 1) = strRws(Cnt - 1)
    Next Cnt
Dim arrOut() As Variant: Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms())
    With WbData.Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
    Let .Value = arrOut()
    .Sort Key1:=Worksheets("consultant doctor").Range("C7"), Header:=True
    .Font.Name = "Times New Roman"
    .Font.Size = 13
    .Columns("D:X").NumberFormat = "0.00"
    .EntireColumn.AutoFit
    .Borders.LineStyle = xlContinuous
    End With
' Adding extra rows and stuff for  Worksheets("consultant doctor") ================
'        Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
 Call DropItIn3(WbData.Worksheets("consultant doctor"), UBound(strRws(), 1) + 1, 8, 34, 27, 7)                                            '  Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
' second output worksheet
'Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
 Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
 ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
    For Cnt = 1 To UBound(strRws(), 1) + 1
     Let Rws(Cnt, 1) = strRws(Cnt - 1)
    Next Cnt
 Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms())
    With WbData.Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
     Let .Value = arrOut()
     .Sort Key1:=Worksheets("Specialist Doctor").Range("C7"), Header:=True
     .Font.Name = "Times New Roman"
     .Font.Size = 13
     .Columns("D:X").NumberFormat = "0.00"
     .EntireColumn.AutoFit
     .Borders.LineStyle = xlContinuous
    End With
' Adding extra rows and stuff for  Worksheets("Specialist Doctor") ==================
'        Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
 Call DropItIn3(WbData.Worksheets("Specialist Doctor"), UBound(strRws(), 1) + 1, 8, 34, 27, 7)                                            '  Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted

End Sub



'  Call '  Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
'Worksheets("consultant doctor"), UBound(strRws(), 1) + 1 ,    8    ,   34      27,     7
'                                     88    ,       8      ,         34     ,     27        ,    7
Sub DropItIn3(Ws As Worksheet, RwsCnt As Long, SttRw As Long, FstBkRw As Long, DtaRws As Long, ExtRws As Long)    '      https://eileenslounge.com/viewtopic.php?p=271047&sid=d23ea475322d2edf06b70bfeaa95726b#p271047
' Header
 ThisWorkbook.Worksheets("TempSht").Range("A7:X7").Copy
 Ws.Range("A" & SttRw - 1 & ":X" & SttRw - 1 & "").PasteSpecial Paste:=xlPasteFormats  '     https://docs.microsoft.com/en-us/office/vba/api/excel.range.pastespecial       https://docs.microsoft.com/de-de/office/vba/api/excel.xlpastetype
' Insert extra rows
'  Worksheets("TempSht").Range("A35:X41").Copy
Dim Cnt As Long
'    For Cnt = FstBkRw To ((((Int(RwsCnt / DtaRws) + 1) * DtaRws) + (((Int(RwsCnt / DtaRws) + 1) - 1) * ExtRws) + (SttRw - 1))) - (DtaRws + ExtRws) Step DtaRws + ExtRws  '  This misses the last section
    For Cnt = FstBkRw To ((((Int(RwsCnt / DtaRws) + 1) * DtaRws) + (((Int(RwsCnt / DtaRws) + 1) - 1) * ExtRws) + (SttRw - 1))) Step DtaRws + ExtRws
     ThisWorkbook.Worksheets("TempSht").Range("A35:X41").Copy
     Ws.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Insert shift:=xlShiftDown '                  Value = Worksheets("TempSht").Range("A35:X41").Formula
'     Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(7, 24).Sort key1:=Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 2), Header:=False   '   sorting here will clear the clipboard
    Next Cnt

End Sub[code]
You do not have the required permissions to view the files attached to this post.
\ -_- / :heavy:

User avatar
Doc.AElstein
5StarLounger
Posts: 1149
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Transfer specific columns if a condition is met

Post by Doc.AElstein »

Hi, ( a last time for a while...)
Here is solution 4
This solution is best looked at in comparison with my solution1,

It is almost the same, and for the sake of clarity and comparison I have only done the first worksheet again.

The only difference is that I have done an array sort or bubble sort, sort of, on the full arrays for the worksheet, so that the data is all sorted in one go. So there is no need to sort each segment. Because of this, the results are now almost exactly as your desired.
I am not sure if this will be better or worse in terms of speed than Solution1 . I will leave that to you to check that

As with solution 1, if you want to use solution4 , and can’t figure out how to make it work for the second data worksheet also, then I will look in again when I have time and help further, in a few days.
I wont post any more for a while. I think you have enough to be going on with!

My macro is in the next post, and in the attached workbook , and here
You do not have the required permissions to view the files attached to this post.
Last edited by Doc.AElstein on 05 Jul 2020, 21:46, edited 3 times in total.
\ -_- / :heavy:

User avatar
Doc.AElstein
5StarLounger
Posts: 1149
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Transfer specific columns if a condition is met

Post by Doc.AElstein »

Macro for last post. See last post for explanations

Code: Select all

Sub VBAArrayTypeAlternativeToFilterSolution4()  '                                                       BY M. Doc.AElstein .......... https://eileenslounge.com/viewtopic.php?p=245238#p245238
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = Worksheets("Main workbook").Range("K1:K" & Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Get row indicies for the two output worksheets
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7"
Dim Cnt As Long
    For Cnt = 11 To UBound(arrK(), 1)
        If arrK(Cnt, 1) = "Positive" Then  '/////////
         Let strSuc = strSuc & " " & Cnt
        Else
         Let strSpit = strSpit & " " & Cnt
        End If
    Next Cnt
Debug.Print strSuc
' First output worksheet
Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' sorting with Arrays
Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
 Let strNms() = Application.Index(Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
Dim rOuter As Long ' ========"Left Hand"=========================Outer Loop=====================================
    For rOuter = 2 To UBound(strNms)
    Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
        For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
            If strNms(rOuter) > strNms(rInner) Then
            Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
             Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
            Dim TempRs As String
             Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0  not 1
            Else
            End If
        Next rInner ' -----------------------------------------------------------------------
    Next rOuter ' ==================End  Outer Loop===============================================================
' we must now re make strsuc
 Let strSuc = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1  to give us the number of row indicies
Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1
    For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
     Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) '           https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
    Next Cnt
 Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
    For Cnt = 1 To UBound(strRws(), 1) + 1
     Let Rws(Cnt, 1) = strRws(Cnt - 1)
    Next Cnt
Dim arrOut() As Variant
 Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), Clms())
 Let Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()
Rem Part B)
' Header
 Worksheets("TempSht").Range("A7:X7").Copy
 Worksheets("consultant doctor").Range("A7:X7").PasteSpecial Paste:=xlPasteAll    '     https://docs.microsoft.com/en-us/office/vba/api/excel.range.pastespecial       https://docs.microsoft.com/de-de/office/vba/api/excel.xlpastetype
' All formats in one go for each segmant from the temporary blue print worksheet
 Worksheets("TempSht").Range("A8:X41").Copy
 Worksheets("consultant doctor").Range("A8:X" & ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 & "").PasteSpecial Paste:=xlPasteFormats   '
' Formulas
  Worksheets("TempSht").Range("A35:X41").Copy
    For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
     Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).PasteSpecial Paste:=xlFormulas '                  Value = Worksheets("TempSht").Range("A35:X41").Formula
'     Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(7, 24).Sort key1:=Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 2), Header:=False   '   sorting here will clear the clipboard
    Next Cnt
''' Sorting  NO LONGER NEEDED
''    For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
''     Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(7, 24).Sort key1:=Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 2), Header:=False
''    Next Cnt

'    With Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
'    Let .Value = arrOut()
'    .Sort Key1:=Worksheets("consultant doctor").Range("C7"), Header:=True
'    .Font.Name = "Times New Roman"
'    .Font.Size = 13
'    .Columns("D:X").NumberFormat = "0.00"
'    .EntireColumn.AutoFit
'    End With
'' second output worksheet
''Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
'Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
'ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
'    For Cnt = 1 To UBound(strRws(), 1) + 1
'     Let Rws(Cnt, 1) = strRws(Cnt - 1)
'    Next Cnt
' Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), Clms())
'    With Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
'     Let .Value = arrOut()
'     .Sort Key1:=Worksheets("Specialist Doctor").Range("C7"), Header:=True
'     .Font.Name = "Times New Roman"
'     .Font.Size = 13
'     .Columns("D:X").NumberFormat = "0.00"
'     .EntireColumn.AutoFit
'    End With
End Sub

\ -_- / :heavy:

menajaro
2StarLounger
Posts: 168
Joined: 24 Jan 2019, 10:58

Re: Transfer specific columns if a condition is met

Post by menajaro »

Once again many many thanks Alan for your effort!
I think it is better to delete temporary worksheet
I don't mind going about it an entirely different way if possible.

User avatar
Doc.AElstein
5StarLounger
Posts: 1149
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Transfer specific columns if a condition is met

Post by Doc.AElstein »

Hi
menajaro wrote:
06 Jul 2020, 20:22
...I think it is better to delete temporary worksheet.....
I am not quite sure what you are saying there.
Never mind…
I will take a guess that you don’t want to have anything to do with a blueprint / Temporary worksheet anywhere.
I will take a further guess that you want the macro to painstakingly add all the extra stuff.
I will do a final solution for you, just for completeness.
But , as I said before, once you start wanting to add this sort of modification then really you should forget any macro that I have ever done for you ever. You would be best to start all over again using more conventional Spreadsheet techniques
Anyone that knows more conventional VBA can help you a lot better than I can. I only know a minute part of VBA and the more usual conventional stuff I don’t know too well , and most people who know a bit of VBA know it much better than me

My solution 5 is something similar to my last solution 4 in the ‘ First half ## ( there are two of those sections, one for each output worksheet)
That puts all the data in, sorted correctly

'Second half ## is messy and time consuming, and puts all the extra stuff in. ( there are two of those sections, one for each output worksheet)
I have not done all the formating, but I have done most of it and all the difficult stuff. I also did the slightly clever stuff with the formulas. You should be able to do the rest. ( I personally always use a macro recorder to record me doing formatting stuff manually. That gives me the basic coding, which I then modify slightly )


I have done this solution for both worksheets, so it is my final solution for you.
I can help you with minor modifications, but really, you’d be best asking someone else for the final macro, and don’t bother to show them any of my macros as that will likely only confuse them unnecessarily

_.____
menajaro wrote:
06 Jul 2020, 20:22
...I don't mind going about it an entirely different way if possible.
It is almost certainly possible in many different ways. But I am not the best person to ask for the other ways.

Alan

My macro wont fit in a post here, but it is in the attached workbook , and here
You do not have the required permissions to view the files attached to this post.
\ -_- / :heavy:

menajaro
2StarLounger
Posts: 168
Joined: 24 Jan 2019, 10:58

Re: Transfer specific columns if a condition is met

Post by menajaro »

Brilliant! Thank you very much Alan
please to complete the work, you must adjust some points as follows:-
1- insert borders in column headers, row totals, and previous totals rows.
2- Add condition if the remain items is less than 27 then to insert rows directly after them.
3- adjust the pages vertical and horizontal page breaks automatically.
Hope this will be clear enough when you peruse Desired output file
Many thanks for your time again.
You do not have the required permissions to view the files attached to this post.

User avatar
Doc.AElstein
5StarLounger
Posts: 1149
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Transfer specific columns if a condition is met

Post by Doc.AElstein »

Hi
_ 1- Extra Borders..
You should have been able to figure that out yourself. If you have made any attempt to understand the macro, then you will see straight away how to do that, or at least come close…._
_...In the macro are two section which put in most of the formatting. It is a loop that is done 3-4 times, 4 times for worksheet consultant doctor and 3 times for worksheet Specialist Doctor

Code: Select all

    For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
    ' Most borders
     Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(27, 24).Borders.LineStyle = xlContinuous
    ' Sum formulas
     Let ThisWorkbook.Worksheets("consultant doctor").Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
     Let ThisWorkbook.Worksheets("consultant doctor").Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
 '     First signature                 Second signature                    third signature                 Fourth signature                    Fifth signature
     Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
   ' Bold stuff
     Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
 
     Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 1 & "").Value = "The total"
     Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "").Value = "Previous total"
    Next Cnt
Look at the first code line for the ‘Most borders

' Most borders

Code: Select all

     Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(27, 24).Borders.LineStyle = xlContinuous
That code line is putting 27 rows of borders in

You can either
_(i)
put two more code lines in to put the borders for row totals, and previous totals rows, ( which are almost identical on the LHS to those for the formulas )

Code: Select all

     Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 1 & ":X" & Cnt + 1 & "").Borders.LineStyle = xlContinuous
     Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & ":X" & Cnt + 7 & "").Borders.LineStyle = xlContinuous
(You could use similar code lines to those two to put the different height format in)
or
_(ii)
change the ‘Most borders so that it extends into an extra line above and below

Code: Select all

     Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
That last solution, ( ii) , will also put the borders around the header
_._________

_ 2- ....Add condition if the remain items is less than 27 then to insert rows directly after them.... ????
I don’t understand what you are saying there

_._________

_3- Page Breaks
I don’t know how to do that. I don’t understand anything about vertical and horizontal page breaks in Excel. I can’t help you there.

_._________

I will take a further guess that you want to delete the last lines 143 in worksheet consultant doctor and 109 for worksheet Specialist Doctor
You should be able to work that out yourself:
Go back to my first post, and look at my maths logic. In the macro we have
((Segs * 27) + ((Segs - 1) * 7) + 7)
This returns us for consultant doctor 136 and for worksheet Specialist Doctor 102
I think you can see how to get 143 and 109 from those two numbers ( I will give you a clue: The answer is +7 )
So you can work out from that which line needs to be deleted. The two code lines for that will need to go at the end of the two 'Second half code sections

_.________

If you have difficulty getting the correct syntax for formatting and deleting lines, then , as I have told you many times already , do what I do : Do the thing manually whilst the macro recorder is running. You can find tons of stuff on the internet telling you how to do that.
https://de.lmgtfy.com/?q=vba+using+the+macro+recorder
I expect you can also find lots of information in your native language to tell you how to use the macro recorder.
https://lmgtfy.com/?q=vba+uruchamia+nagrywanie+makr
You may be able to get the coding for the page breaks as well that way. I am not sure. I don’t know how to do that manually , so in that case a macro recording won’t help me. It might help you if you know how to do it manually…

Alan
Last edited by Doc.AElstein on 10 Jul 2020, 06:10, edited 1 time in total.
\ -_- / :heavy:

menajaro
2StarLounger
Posts: 168
Joined: 24 Jan 2019, 10:58

Re: Transfer specific columns if a condition is met

Post by menajaro »

Another perfect explanation - super easy to understand!
Again, thank you so much Alan for all your time and help!

User avatar
Doc.AElstein
5StarLounger
Posts: 1149
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Transfer specific columns if a condition is met

Post by Doc.AElstein »

You is welcome ( if you figure out how to do the page breaks, then please let us know. I would be interested to see how that is done )
Alan
\ -_- / :heavy: