Hello,
HansV wrote: ↑16 Jan 2023, 11:08
Doc
.AElstein may have a better method..
The respected honourable Mr Doc
.AElstein still can’t log in very easily to his old account, so maybe I can fill in for him :)
_._____________________________________
I have no idea if the alternative method I give here is any better or worse. So I just give it as an alternative, that's all. It’s the nearest I can think of as a solution in a similar vain to my (Doc
.AElstein’s) original:
_1) First, the extra 2 columns required in the new requirement
…
Transfer columns M & N With the division of values ,..
whole and decimal ..
into two cells ...
they are got initially from just doubling/duplicating the column number for M & N in the column idicle array,
So
Clms() = Array(6, 5, 4, 13, 14) is changed to clms() = Array(6, 5, 4, 13, 13,14, 14)
_2) Then the duplicated columns need to be fiddled a bit so that for each pair
_ b)one displays the integer
and
_a) the other the decimal, ( as a whole number ) .
_2a) For the decimal… The first thing I Google’d suggested something like
celllvalue –
TRUNC(cellvalue)
, for a spreadsheet formula solution. Modifying that a bit for the data given to get it shown as a whole number would be a formula in a cell something like
=(D19-TRUNC(D19))*100
That lent itself nicely to an Evaluate Range one liner type solution in VBA.
Something like
Evaluate("=(D19:D20-TRUNC(D19:D20))*100")
_2b) For the whole part… In a spreadsheet we would do
=INT(E19) , so this lends itself nicely again to an Evaluate Range one liner
Something like
Evaluate("=INT(E19:E20)")
The version I give is a fairly simple form to demonstrate the method alternative.
I can’t help you with the various formatting and left – right, page breaks, right left and centre stuff being considered, because I have little knowledge of all that. I expect you can figure that out from what Hans has been doing for you already, or what you seem to have done yourself in your latest attempt . (You should note however, that should there be any performance advantages from my method, then these are wasted once you start doing a lot of formatting, since all those spreadsheet interaction things tend to slow that down).
The demo file I upload is a shortened version of your last file, and the code example is a simplified stripped down version. It’s only intended to demonstrate my method alternative for the new requirement …
Transfer columns M & N with the division of values ,..
whole and decimal fraction ..
into two cells
Code: Select all
Option Explicit
Sub TransferSomeClmsSourceShtTo2ShtsAndSptSomeRstClmsIntoIntAndDec() ' https://eileenslounge.com/viewtopic.php?p=303374#p303374
' Worksheets and source datas Info
Dim wS As Worksheet, wM As Worksheet, wA As Worksheet, Em As Long
Set wS = Worksheets("Source"): Set wM = Worksheets("Suksesful"): Set wA = Worksheets("UnSuksesful")
Let Em = wS.Range("A" & Rows.Count & "").End(xlUp).Row
Dim arrK() As Variant: Let arrK() = wS.Range("K1:L" & Em).Value
'
Dim strY As String, strAnuver As String
Dim Clms() As Variant, strRws() As String, Rws() As String
Dim arrOut() As Variant
Dim Cnt As Long
Let strY = "7"
Let strAnuver = "7"
For Cnt = 8 To Em
If arrK(Cnt, 2) Like "*Excellent" Then
If arrK(Cnt, 1) = "Y" Then
Let strY = strY & " " & Cnt
Else
Let strAnuver = strAnuver & " " & Cnt
End If
End If
Next Cnt
'Output successful
Let Clms() = Array(6, 5, 4, 13, 13, 14, 14)
Let strRws() = Split(strY)
ReDim Rws(1 To UBound(strRws()) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws()) + 1
Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Let arrOut() = Application.Index(wS.Cells, Rws(), Clms())
'wM.Activate
wM.Cells.Clear
With wM.Range("A18").Resize(UBound(arrOut, 1), UBound(arrOut, 2))
.Value2 = arrOut()
End With
' the duplicated columns need to be fiddled a bit so that one displays the integer and the other the decimal
Let Em = UBound(arrOut(), 1)
With wM.Range("D19:D" & 19 + Em - 1 - 1 & "")
.Value2 = wM.Evaluate("=(D19:D" & 19 + Em - 1 - 1 & "-IF({1},Trunc(D19:D" & 19 + Em - 1 - 1 & ")))*100")
End With
With wM.Range("E19:E" & 19 + Em - 1 - 1 & "")
.Value2 = wM.Evaluate("=IF({1},INT(E19:E" & 19 + Em - 1 - 1 & "))")
End With
With wM.Range("F19:F" & 19 + Em - 1 - 1 & "")
.Value2 = wM.Evaluate("=(F19:F" & 19 + Em - 1 - 1 & "-IF({1},Trunc(F19:F" & 19 + Em - 1 - 1 & ")))*100")
End With
With wM.Range("G19:G" & 19 + Em - 1 - 1 & "")
.Value2 = wM.Evaluate("=IF({1},INT(G19:G" & 19 + Em - 1 - 1 & "))")
End With
'Output Unsuccessful
'Clms = Array(6, 5, 4, 13, 14)
Let strRws() = Split(strAnuver)
ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Let arrOut() = Application.Index(wS.Cells, Rws(), Clms())
'wA.Activate
wA.Cells.Clear
With wA.Range("A18").Resize(UBound(arrOut, 1), UBound(arrOut, 2))
.Value2 = arrOut()
End With
' the duplicated columns need to be fiddled a bit so that one displays the integer and the other the decimal
Let Em = UBound(arrOut(), 1)
With wA.Range("D19:D" & 19 + Em - 1 - 1 & "")
.Value2 = wA.Evaluate("=(D19:D" & 19 + Em - 1 - 1 & "-IF({1},Trunc(D19:D" & 19 + Em - 1 - 1 & ")))*100")
End With
With wA.Range("E19:E" & 19 + Em - 1 - 1 & "")
.Value2 = wA.Evaluate("=IF({1},INT(E19:E" & 19 + Em - 1 - 1 & "))")
End With
With wA.Range("F19:F" & 19 + Em - 1 - 1 & "")
.Value2 = wA.Evaluate("=(F19:F" & 19 + Em - 1 - 1 & "-IF({1},Trunc(F19:F" & 19 + Em - 1 - 1 & ")))*100")
End With
With wA.Range("G19:G" & 19 + Em - 1 - 1 & "")
.Value2 = wA.Evaluate("=IF({1},INT(G19:G" & 19 + Em - 1 - 1 & "))")
End With
End Sub
(aka Doc
.AElstein , DocAElstein , dr.aelstein )
You do not have the required permissions to view the files attached to this post.
