Transfer specific columns from one sheet into two sheets

[menajaro]

Hello everyone
I have posted a thread at this link
https://www.excelforum.com/excel-progra ... heets.html" onclick="window.open(this.href);return false;
Thanks in advance for taking the time to read my post and for any assistance offered.
I have 3 sheets in a workbook (source sheet - successful sheet - Unsuccessful sheet)
Issue: I need to write a macro that will Transfer six columns of data if a condition is met. The condition is "Y" in column K in source sheet. If "Y" exist in Column K then Transfer the Columns from column A to column F & M to the Columns from column A to column G in successful sheet ... and If "Y" does not exist in column k then Transfer the Columns from column A to column J & M to the Columns from column A to column K in Unsuccessful sheet.
I have tried to write a macro but have had no success ... If possible I need to avoid loops as original data is too large
I really appreciate your help in this regard.Thanks a lot

[HansV]

Try this macro:

Code: Select all

Sub TransferData()
    With Worksheets("Source")
        .Range("A1").Value = "Head 11"
        .Range("A2").Value = "Y"
        .Range("A10").CurrentRegion.AdvancedFilter _
            Action:=xlFilterCopy, _
            CriteriaRange:=.Range("A1:A2"), _
            CopyToRange:=Worksheets("Successful").Range("A1:G1")
        .Range("A2").Value = "<>Y"
        .Range("A10").CurrentRegion.AdvancedFilter _
            Action:=xlFilterCopy, _
            CriteriaRange:=.Range("A1:A2"), _
            CopyToRange:=Worksheets("Unsuccessful").Range("A1:K1")
        .Range("A1:A2").ClearContents
    End With
End Sub

[menajaro]

Thanks a lot Mr. Hans for your reply
I appreciate you taking the time to answer my question But I want to improve speed code's by using array
or Perhaps there is a better and faster way to achieve that if possible.Thank you

[HansV]

The code that I posted uses Excel's very efficient Advanced Filter, I don't think other methods would be faster.

[menajaro]

Thanks a lot for your reply
After testing the code on the original file ( with a lot of rows and columns - about 20000 rows ) It took a very long time
I greatly appreciate your effort to help me.

[Doc.AElstein]

Hi menajaro,
( I think you may have an error in your test data : In your data NAME22 is missing from worksheet Unsuccessful )

I have no idea if this which I have done will be quicker, slower, or it may even crap out and not work at all for a large amount of data.
But this is the typical “VBA Array” type alternative done for things like this.

Below are a few variations of the same basic routine. I would suggest that you test these routines from me and those routines from Hans and Mumps1 with some data with maybe an increasing number of rows, like
50
100
500
1000
3000
-…etc…
Do it in stages and compare the results and speeds. I would expect that my routines may not work at all for many thousands of rows….

Code: Select all

Sub VBAArrayTypeAlternativeToFilter4()
Dim arrK() As Variant
 Let arrK() = Worksheets("Source").Range("K10:K" & Worksheets("Source").Range("K" & Rows.Count & "").End(xlUp).Row & "").Value
' Indicies needed  for output arrays
Dim strSuc As String, strSpit As String ' For like "1 3 5 .......42"
 Let strSuc = "1": Let strSpit = "1" ' Header row 1
Dim cnt As Long
    For cnt = 3 To UBound(arrK(), 1)
        If arrK(cnt, 1) = "Y" Then
         Let strSuc = strSuc & " " & cnt
        Else
         Let strSpit = strSpit & " " & cnt
        End If
    Next cnt
'Output Suc
Dim arrOut() As Variant: Let arrOut() = Application.Index(Worksheets("Source").Cells, Application.Transpose(Split(strSuc)), Array(1, 2, 3, 4, 5, 6, 13))
 Let Worksheets("successful").Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
'Output UnSuc (Spit)
 Let arrOut() = Application.Index(Worksheets("Source").Cells, Application.Transpose(Split(strSpit)), Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 13))
 Let Worksheets("Unsuccessful").Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
End Sub


Sub VBAArrayTypeAlternativeToFilter3()
Dim arrAll() As Variant, arrK() As Variant
 Let arrAll() = Worksheets("Source").Range("A10").CurrentRegion.Value
 Let arrK() = Worksheets("Source").Range("K10:K" & 10 + UBound(arrAll(), 1) - 1 & "").Value
' Indicies needed  for output arrays
Dim strSuc As String, strSpit As String ' For like "1 3 5 .......42"
 Let strSuc = "1": Let strSpit = "1" ' Header row 1
Dim cnt As Long
    For cnt = 3 To UBound(arrK(), 1)
        If arrK(cnt, 1) = "Y" Then
         Let strSuc = strSuc & " " & cnt
        Else
         Let strSpit = strSpit & " " & cnt
        End If
    Next cnt
'Output Suc
Dim arrOut() As Variant: Let arrOut() = Application.Index(arrAll(), Application.Transpose(Split(strSuc)), Array(1, 2, 3, 4, 5, 6, 13))
 Let Worksheets("successful").Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
'Output UnSuc (Spit)
 Let arrOut() = Application.Index(arrAll(), Application.Transpose(Split(strSpit)), Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 13))
 Let Worksheets("Unsuccessful").Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
End Sub
'
Sub VBAArrayTypeAlternativeToFilter()
' Range Info
Dim arrAll() As Variant, arrK() As Variant
 Let arrAll() = Worksheets("Source").Range("A10").CurrentRegion.Value
 Let arrK() = Worksheets("Source").Range("K10:K" & 10 + UBound(arrAll(), 1) - 1 & "").Value
' Indicies needed  for output arrays
Dim strSuc As String, strSpit As String ' For like "1 3 5 .......42"
 Let strSuc = "1": Let strSpit = "1" ' Header row 1
Dim cnt As Long
    For cnt = 3 To UBound(arrK(), 1)
        If arrK(cnt, 1) = "Y" Then
         Let strSuc = strSuc & " " & cnt
        Else
         Let strSpit = strSpit & " " & cnt
        End If
    Next cnt
'Output Suc
Dim clms() As Variant: Let clms() = Array(1, 2, 3, 4, 5, 6, 13) ' column A to column F & M
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As Variant: Let Rws() = Application.Transpose(strRws())
'
Dim arrOut() As Variant: Let arrOut() = Application.Index(arrAll(), Rws(), clms())
 Let Worksheets("successful").Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
'Output UnSuc (Spit)
 Let clms() = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 13) ' column A to column J & M
 Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
 Let Rws() = Application.Transpose(strRws())
 Let arrOut() = Application.Index(arrAll(), Rws(), clms())
 Let Worksheets("Unsuccessful").Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
End Sub
'
Sub VBAArrayTypeAlternativeToFilter2()
' Range Info
Dim arrAll() As Variant, arrK() As Variant
 Let arrAll() = Worksheets("Source").Range("A10").CurrentRegion.Value
 Let arrK() = Worksheets("Source").Range("K10:K" & 10 + UBound(arrAll(), 1) - 1 & "").Value
' Indicies needed  for output arrays
Dim strSuc As String, strSpit As String ' For like "1 3 5 .......42"
 Let strSuc = "1": Let strSpit = "1" ' Header row 1
Dim cnt As Long
    For cnt = 3 To UBound(arrK(), 1)
        If arrK(cnt, 1) = "Y" Then
         Let strSuc = strSuc & " " & cnt
        Else
         Let strSpit = strSpit & " " & cnt
        End If
    Next cnt
'Output Suc
Dim clms() As Variant: Let clms() = Array(1, 2, 3, 4, 5, 6, 13) ' column A to column F & M
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1), 1 To 1)
    For cnt = 1 To UBound(strRws(), 1)
     Let Rws(cnt, 1) = strRws(cnt - 1)
    Next cnt
Dim arrOut() As Variant: Let arrOut() = Application.Index(arrAll(), Rws(), clms())
 Let Worksheets("successful").Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
'Output UnSuc (Spit)
 Let clms() = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 13) ' column A to column J & M
 Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
 ReDim Rws(1 To UBound(strRws(), 1), 1 To 1)
    For cnt = 1 To UBound(strRws(), 1)
     Let Rws(cnt, 1) = strRws(cnt - 1)
    Next cnt
 Let arrOut() = Application.Index(arrAll(), Rws(), clms())
 Let Worksheets("Unsuccessful").Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
End Sub
'




' http://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4210408

Alan

Ref:
http://www.excelforum.com/excel-new-use ... ost4210408" onclick="window.open(this.href);return false;

[Doc.AElstein]

Another to try

Code: Select all

Sub VBAArrayTypeAlternativeToFilter6()
' Range Info
Dim arrK() As Variant: Let arrK() = Worksheets("Source").Range("K10:K" & Worksheets("Source").Range("K" & Rows.Count & "").End(xlUp).Row & "").Value
' Indicies needed  for output arrays
Dim strSuc As String, strSpit As String ' For like "1 3 5 .......42"
 Let strSuc = "1": Let strSpit = "1" ' Header row 1
Dim cnt As Long
    For cnt = 3 To UBound(arrK(), 1)
        If arrK(cnt, 1) = "Y" Then
         Let strSuc = strSuc & " " & cnt
        Else
         Let strSpit = strSpit & " " & cnt
        End If
    Next cnt
'Output Suc
Dim clms() As Variant: Let clms() = Array(1, 2, 3, 4, 5, 6, 13) ' column A to column F & M
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1), 1 To 1)
    For cnt = 1 To UBound(strRws(), 1)
     Let Rws(cnt, 1) = strRws(cnt - 1)
    Next cnt
Dim arrOut() As Variant: Let arrOut() = Application.Index(Worksheets("Source").Cells, Rws(), clms())
 Let Worksheets("successful").Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
'Output UnSuc (Spit)
 Let clms() = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 13) ' column A to column J & M
 Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
 ReDim Rws(1 To UBound(strRws(), 1), 1 To 1)
    For cnt = 1 To UBound(strRws(), 1)
     Let Rws(cnt, 1) = strRws(cnt - 1)
    Next cnt
 Let arrOut() = Application.Index(Worksheets("Source").Cells, Rws(), clms())
 Let Worksheets("Unsuccessful").Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
End Sub

[menajaro]

Hi Doc.AElstein ,
Thanks a lot for your reply
Give me some time to work on the original file and I will tell you about any notes
Thank you in advance for any effort
Best and kind regards

[menajaro]

Thank you very very very much Doc.AElstein
All solutions are working like charm. You are great personality
I've tested all the solutions and I'm with the last solution.
Where the run time took only two seconds on about 20,000 rows and about 200 columns.
Only one note is that data transfer should start from the beginning of the second row.
Thank you very very much for this great help

[Doc.AElstein]

...Only one note is that data transfer should start from the beginning of the second row.

Ah, I made mistake...

All .Cells are used, so Start is 10 instead of 1
This and a few minor modification to adjust indices to correct:

Code: Select all

 Sub VBAArrayTypeAlternativeToFilter7()
' Range Info
Dim arrK() As Variant: Let arrK() = Worksheets("Source").Range("K1:K" & Worksheets("Source").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Indicies needed  for output arrays
Dim strSuc As String, strSpit As String ' For like "1 3 5 .......42"
 Let strSuc = "10": Let strSpit = "10" ' Header row 1
Dim cnt As Long
    For cnt = 12 To UBound(arrK(), 1)
        If arrK(cnt, 1) = "Y" Then
         Let strSuc = strSuc & " " & cnt
        Else
         Let strSpit = strSpit & " " & cnt
        End If
    Next cnt
'Output Suc
Dim clms() As Variant: Let clms() = Array(1, 2, 3, 4, 5, 6, 13) ' column A to column F & M
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("Source").Cells, Rws(), clms())
 Let Worksheets("successful").Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
'Output UnSuc (Spit)
 Let clms() = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 13) ' column A to column J & M
 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("Source").Cells, Rws(), clms())
 Let Worksheets("Unsuccessful").Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
End Sub

( This is big surprise to me that code works for so many rows . I did think it is too big – For me it would not work for large rows I think )

[menajaro]

Hi Doc.AElstein ,
There is no mistake ... You are a star
I must be honest with you my dear friend ... this is the truth, This work is a wonderful surprise for you and me
I have Two extra points to complete this wonderful treasure
The first point is I need to sort the names alphabetically depending on the column F In both of the two sheets ( successful & Unsuccessful ).
The second point is I need to Add some formats like font type, size, and row height Etc ... In both of the two sheets ( successful & Unsuccessful ).
Thanking you in advance for your insight.

[Doc.AElstein]

Hi
Those sort of extra things would probably have to be done using Worksheet interaction techniques. That may slow things down a bit.
_.__

The first point is I need to sort the names alphabetically depending on the column F In both of the two sheets ( successful & Unsuccessful ).

The Range.Sort method ( https://docs.microsoft.com/de-de/office ... range.sort" onclick="window.open(this.href);return false; would probably be the thing to use there.
Maybe if you can give a workbook with some rows with some made up Names in them then I can take a look at that, maybe tomorrow
_.____

The second point is I need to Add some formats like font type, size, and row height Etc ... In both of the two sheets ( successful & Unsuccessful ).
.

For things like formatting, I tend to find it easier to make a macro recording while doing the formatting, and then modify that code given by the recorder. ( https://www.excel-easy.com/vba/examples ... order.html" onclick="window.open(this.href);return false; )

See if you can make any head way yourself first with that, then maybe tomorrow I or someone can guide you further with all that

Alan

[HansV]

Here is an example based on Alan's macro. I'll leave it to you to modify it for your exact preferences.

Code: Select all

Sub VBAArrayTypeAlternativeToFilter7()
' Range Info
Dim arrK() As Variant: Let arrK() = Worksheets("Source").Range("K1:K" & Worksheets("Source").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Indicies needed  for output arrays
Dim strSuc As String, strSpit As String ' For like "1 3 5 .......42"
Let strSuc = "10": Let strSpit = "10" ' Header row 1
Dim cnt As Long
    For cnt = 12 To UBound(arrK(), 1)
        If arrK(cnt, 1) = "Y" Then
         Let strSuc = strSuc & " " & cnt
        Else
         Let strSpit = strSpit & " " & cnt
        End If
    Next cnt
'Output Suc
Dim clms() As Variant: Let clms() = Array(1, 2, 3, 4, 5, 6, 13) ' column A to column F & M
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("Source").Cells, Rws(), clms())
With Worksheets("successful").Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
    Let .Value = arrOut()
    .Sort Key1:=Worksheets("successful").Range("F1"), Header:=True
    .Font.Name = "Times New Roman"
    .Font.Size = 12
    .RowHeight = 15
    .EntireColumn.AutoFit
End With
'Output UnSuc (Spit)
Let clms() = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 13) ' column A to column J & M
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("Source").Cells, Rws(), clms())
With Worksheets("Unsuccessful").Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
    Let .Value = arrOut()
    .Sort Key1:=Worksheets("Unsuccessful").Range("F1"), Header:=True
    .Font.Name = "Comic Sans"
    .Font.Size = 14
    .RowHeight = 17
    .EntireColumn.AutoFit
End With
End Sub

[menajaro]

Special thanks to Mr.Alan's for great and creative solutions...Really working great. I really appreciate your help
Thank you very much Mr. Hans for this great help
Best regards for all of you

[Doc.AElstein]

...Thank you very much ...Best regards for all of you

Thanks for the good feedback.

These sorts of array coding I have from other forum members and forum threads, for example, an Australian guy, apo , has done routines like this many times, http://www.excelforum.com/excel-program ... ost4138868" onclick="window.open(this.href);return false; , and he in turn says he has learnt most from a guy called snb at places like this: http://www.snb-vba.eu/VBA_Arrays_en.html" onclick="window.open(this.href);return false;
snb has also some information on sorting arrays, or rather a .Sort of ArrayList.. http://www.snb-vba.eu/VBA_Arraylist_en.html#L_11" onclick="window.open(this.href);return false;
I do not have much experience with algorithms and the such to do with sorting in arrays. ( There seems to be a recent Thread on this here at Eileen’s Lounge just now ( http://www.eileenslounge.com/viewtopic. ... 70#p245270" onclick="window.open(this.href);return false; )

I do not have enough experience with sorting of arrays to suggest an alternative way to the Range.Sort method. I expect the Range.Sort method could be very efficient. But then we were surprised by the improved performance of the “VBA Array way” performance compared to Mumps1’s .. AutoFilter and Hans’s .AdvancedFilter
It might be worth considering an array sort alternative in the future, but I can’t help there.

Good luck with the project

Alan

( P.s. Remember to keep links to other forums where you post the same question, thanks – have sent you private message to show how to get URL link to post… )

[menajaro]

Thank you very much Mr.Alan's
It's my great pleasure to know a person like you
I have learned a lot from your code and Thanks a lot for this wonderful information
Have a nice time my Professor ... With my best wishes of good and great luck for you forever.
Many thanks and kind regards