Copy multiple discontinuous columns

Tejas Kore

Board Regular
Joined
Nov 2, 2017
Messages
72
Office Version
  1. 365
Platform
  1. Windows
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 ?
 

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.
Try
Code:
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
 
Upvote 0
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
 
Upvote 0
Glad to help & thanks for the feedback.

As for your code I can't see anything that needs changing, other than maybe
Code:
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
 
Upvote 0
glad to help & thanks for the feedback.

As for your code i can't see anything that needs changing, other than maybe
Code:
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!!! :)
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,213,565
Messages
6,114,338
Members
448,570
Latest member
rik81h

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top