Copy multiple discontinuous columns

[Tejas Kore]

Hi Friends,

I am trying to copy multiple discontinuous columns.

rU = Null
For var = 0 To c.Count - 1
rU = Union(rU, wsI.Columns(Int(c.Items()(var))))
Next var

rU.Copy

Here I have my column numbers in a dictionary.I am running a for loop to populate all columns in rU variable.
But I am getting this error "Run-time error '424':
Object Required "
Do I have to set this rU variable ?

 

[Fluff]

Try

Dim rU As Range
Set rU = Nothing
For Var = 0 To c.Count - 1
   If rU Is Nothing Then
      Set rU = WSi.Columns(Int(c.Items()(Var)))
   Else
      Set rU = Union(rU, WSi.Columns(Int(c.Items()(Var))))
   End If
Next Var

rU.Copy

 

[Tejas Kore]

Thanks a LOT!!!!! Fluff. It worked perfectly fine.

Here is what I was trying to do.
I wanted to copy multiple discontinuous columns on the basis of provided column headers and paste it into new workbook.
Here "Y 2" and "A 1" are my column headers and "1_Result" is the name of the new workbook where copied data is to be pasted.

Actually this is test data which is why I took only two columns. I real scenario I have 20 to 30 columns.
Any help to fine tune this piece of code would be appreciated.

Sub Sample()
Dim wbI As Workbook, wbO As Workbook
Dim wsI As Worksheet, wsO As Worksheet
Dim i As Integer
Dim lColumn As Long
Dim c, var, column_name, strsearch, column_arr As Variant
Dim rU As Range

Set c = CreateObject("scripting.dictionary")

Filepath = "C:\Users\tejas\Desktop\Test"



Set wbI = ThisWorkbook
Set wsI = wbI.Sheets("Sheet1")

lColumn = wsI.Cells(1, Columns.Count).End(xlToLeft).Column
wsI.Rows(1).Replace What:=" ", Replacement:=""

Set wbO = Workbooks.Add
Set wsO = wbO.Sheets("Sheet1")


wbO.SaveAs Filename:=Filepath & Str(1) & "_Result.xlsx"


column_arr = Array("Y2", "A1")
For Each strsearch In column_arr


Set column_name = wsI.Rows(1).Find(What:=strsearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)


MsgBox (column_name.Column)
If column_name Is Nothing Then
MsgBox (strsearch & " Not Found")
Else
c.Add strsearch, column_name.Column
End If
Next strsearch

Set rU = Nothing

For var = 0 To c.Count - 1
If rU Is Nothing Then
Set rU = wsI.Columns(Int(c.Items()(var)))
Else
Set rU = Union(rU, wsI.Columns(Int(c.Items()(var))))
End If
Next var


rU.Copy
'MsgBox (rU.Count)

wsO.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
wbO.Save
wbO.Close


End Sub

 

[Fluff]

Glad to help & thanks for the feedback.

As for your code I can't see anything that needs changing, other than maybe

Dim c as object, var as long, column_name as range, strsearch as variant, column_arr As Variant

Otherwise everything is being declared as Variant

 

[Tejas Kore]

glad to help & thanks for the feedback.

As for your code i can't see anything that needs changing, other than maybe

dim c as object, var as long, column_name as range, strsearch as variant, column_arr as variant

otherwise everything is being declared as variant

roger that sir!!!

 

[Tejas Kore]

Sub Sample()
Dim wbI As Workbook, wbO As Workbook
Dim wsI As Worksheet, wsO As Worksheet
Dim i As Integer
Dim lColumn As Long
Dim a, c, var, counter, column_name, strsearch, column_arr As Variant
Dim rU As Range

Set c = CreateObject("scripting.dictionary")
Set a = CreateObject("scripting.dictionary")

column_arr_1 = Array("X1", "Y2")
column_arr_2 = Array("Z3", "A1")
column_arr_3 = Array("B1", "C1")
column_arr = Array(column_arr_1, column_arr_2, column_arr_3)

For i = 1 To (UBound(column_arr) - LBound(column_arr) + 1)
a.Add i, column_arr(i - 1)
Next i


Filepath = "C:\Users\tejas\Desktop\Test"


Set wbI = ThisWorkbook
Set wsI = wbI.Sheets("Sheet1")


lColumn = wsI.Cells(1, Columns.Count).End(xlToLeft).Column
wsI.Rows(1).Replace What:=" ", Replacement:=""


'MsgBox ("I am before For")
For counter = 0 To 2
'MsgBox ("I am inside For")
Set wbO = Workbooks.Add
Set wsO = wbO.Sheets("Sheet1")


wbO.SaveAs Filename:=Filepath & Str(a.Keys()(counter)) & "_Result.xlsx"


For Each strsearch In a.Items()(counter)


Set column_name = wsI.Rows(1).Find(What:=strsearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)


MsgBox (column_name.Column)
If column_name Is Nothing Then
MsgBox (strsearch & " Not Found")
Else
c.Add strsearch, column_name.Column
End If
Next strsearch


Set rU = Nothing


For var = 0 To c.Count - 1
If rU Is Nothing Then
Set rU = wsI.Columns(Int(c.Items()(var)))
Else
Set rU = Union(rU, wsI.Columns(Int(c.Items()(var))))
End If
Next var


rU.Copy
'MsgBox (rU.Count)


wsO.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
wbO.Save
wbO.Close


c.RemoveAll
Next counter
End Sub

 

[Tejas Kore]

Sub Sample()
Dim wbI As Workbook, wbO As Workbook
Dim wsI As Worksheet, wsO As Worksheet
Dim i As Integer
Dim lColumn As Long
Dim a, c, var, counter, column_name, strsearch, column_arr As Variant
Dim rU As Range

Set c = CreateObject("scripting.dictionary")
Set a = CreateObject("scripting.dictionary")

column_arr_1 = Array("X1", "Y2")
column_arr_2 = Array("Z3", "A1")
column_arr_3 = Array("B1", "C1")
column_arr = Array(column_arr_1, column_arr_2, column_arr_3)

For i = 1 To (UBound(column_arr) - LBound(column_arr) + 1)
a.Add i, column_arr(i - 1)
Next i


Filepath = "C:\Users\tejas\Desktop\Test"


Set wbI = ThisWorkbook
Set wsI = wbI.Sheets("Sheet1")


lColumn = wsI.Cells(1, Columns.Count).End(xlToLeft).Column
wsI.Rows(1).Replace What:=" ", Replacement:=""


'MsgBox ("I am before For")
For counter = 0 To UBound(column_arr) - LBound(column_arr)
'MsgBox ("I am inside For")
Set wbO = Workbooks.Add
Set wsO = wbO.Sheets("Sheet1")


wbO.SaveAs Filename:=Filepath & Str(a.Keys()(counter)) & "_Result.xlsx"


For Each strsearch In a.Items()(counter)


Set column_name = wsI.Rows(1).Find(What:=strsearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)


'MsgBox (column_name.Column)
If column_name Is Nothing Then
MsgBox (strsearch & " Not Found")
Else
c.Add strsearch, column_name.Column
End If
Next strsearch


Set rU = Nothing


For var = 0 To c.Count - 1
If rU Is Nothing Then
Set rU = wsI.Columns(Int(c.Items()(var)))
Else
Set rU = Union(rU, wsI.Columns(Int(c.Items()(var))))
End If
Next var


rU.Copy
'MsgBox (rU.Count)


wsO.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
wbO.Save
wbO.Close


c.RemoveAll
Next counter
End Sub

 

[Tejas Kore]

Sub Sample()
Dim wbI As Workbook, wbO As Workbook
Dim wsI As Worksheet, wsO As Worksheet
Dim i As Integer
Dim lColumn As Long
Dim a, c, var, counter, column_name, strsearch, column_arr As Variant
Dim rU As Range

Set c = CreateObject("scripting.dictionary")
Set a = CreateObject("scripting.dictionary")

column_arr_1 = Array("X1", "Y2")
column_arr_2 = Array("Z3", "A1")
column_arr_3 = Array("B1", "C1")
column_arr = Array(column_arr_1, column_arr_2, column_arr_3)

For i = 1 To (UBound(column_arr) - LBound(column_arr) + 1)
a.Add i, column_arr(i - 1)
Next i


Filepath = "C:\Users\tejas\Desktop\Test"


Set wbI = ThisWorkbook
Set wsI = wbI.Sheets("Sheet1")


lColumn = wsI.Cells(1, Columns.Count).End(xlToLeft).Column
wsI.Rows(1).Replace What:=" ", Replacement:=""


'MsgBox ("I am before For")
For counter = 0 To UBound(column_arr) - LBound(column_arr)
'MsgBox ("I am inside For")
Set wbO = Workbooks.Add
Set wsO = wbO.Sheets("Sheet1")


wbO.SaveAs Filename:=Filepath & Str(a.Keys()(counter)) & "_Result.xlsx"


For Each strsearch In a.Items()(counter)


Set column_name = wsI.Rows(1).Find(What:=strsearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)


'MsgBox (column_name.Column)
If column_name Is Nothing Then
MsgBox (strsearch & " Not Found")
Else
c.Add strsearch, column_name.Column
End If
Next strsearch


Set rU = Nothing


For var = 0 To c.Count - 1
If rU Is Nothing Then
Set rU = wsI.Columns(Int(c.Items()(var)))
Else
Set rU = Union(rU, wsI.Columns(Int(c.Items()(var))))
End If
Next var


rU.Copy
'MsgBox (rU.Count)


wsO.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
wbO.Save
wbO.Close


c.RemoveAll
Next counter
End Sub