Select and copy multiple columns - but only the visible columns

[SteynBS]

Good day guys.

I have built a working sheet to ease single-column uploads - I want to progress to upload multiple columns but ignore blank or hidden ones.

The sheet works as follow:

Once the changes are entered into column C I have a vba that opens up a blank workbook and copies Columns (A5:C) with this code: Range("A5:C" & lr).Copy

Now I want to copy multiple columns but only the visible ones

Not all the columns will be utilized. for example maybe only Column C and E will be used. All the other columns except A,B,C,E needs to be copied. The others will be hidden manually (or if you have a suggestion other than manually hiding the columns not in use - I am all ears)

Please help me with a code to copy Column A,B and the orange colmns that will be in use

 

[shinigamilight]

Give this one a try
First select all the columns you want to copy including the hidden ones and run this macro.

Sub Column_Copy()
        Dim wk1 As Worksheet
        Set wk1 = Sheets("out") 'input sheet or the sheet from where you are copying the columns
        Dim wk2  As Worksheet
        Set wk2 = Sheets("shift") 'output sheet
        Dim K As Long
        
        For K = 1 To Selection.Columns.Count
                 If wk1.Columns(K).Hidden = False Then
                 wk1.Columns(K).Copy wk2.Cells(1, wk2.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Column)
                 End If
        Next K
        
        wk2.Range("A:A").EntireColumn.Delete
        
End Sub

 

[SteynBS]

G

Give this one a try
First select all the columns you want to copy including the hidden ones and run this macro.

Sub Column_Copy()
        Dim wk1 As Worksheet
        Set wk1 = Sheets("out") 'input sheet or the sheet from where you are copying the columns
        Dim wk2  As Worksheet
        Set wk2 = Sheets("shift") 'output sheet
        Dim K As Long
       
        For K = 1 To Selection.Columns.Count
                 If wk1.Columns(K).Hidden = False Then
                 wk1.Columns(K).Copy wk2.Cells(1, wk2.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Column)
                 End If
        Next K
       
        wk2.Range("A:A").EntireColumn.Delete
       
End Sub

Good day,

Thank you this works good to copy to another sheet in the same workbook. I need to copy it to another newly opened workbook. Below is the current code I use to copy the 1 column.

Something I forgot to mention. Regardless of how many columns are copied. in the new blank sheet after the data has been pasted at the end of the last column with data a new column has to be added with the heading "EOF" and a "X" should populate all the rows of that column all the way to the last row with data in the first columns.

Sub Open_NotePad()
Dim lr As Long
Dim wb As Workbook
Dim fName As String
Dim fileSaveName As String

Application.ScreenUpdating = False
' Capture active file path and build default file path and name
fName = "BWSCL" & " " & Format(Now(), "DD-MMM-YY") & ".csv"

' Go to "Listing" Sheet
Sheets("Maintenance").Activate

' Find last row with data in column A
lr = Cells(Rows.Count, "A").End(xlUp).Row

' Copy columns A-B
Range("A5:C" & lr).Copy

' Insert new workbook
Set wb = Workbooks.Add

Range("A1").Value = "MATNR"
Range("B1").Value = "WERKS"
Range("C1").Value = "BWSCL"
Range("D1").Value = "EOF"
Range("D2").Value = "X"

' Paste copied data
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Range("D2").Select
Selection.Copy
Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row).Select
ActiveSheet.Paste

Application.ScreenUpdating = True
' Prompt for file save name
fileSaveName = Application.GetSaveAsFilename(fName, _
fileFilter:="CSV (Comma delimited)(*.csv), *.csv")

' Save as text file
If Right(fileSaveName, 4) = ".csv" Then
ActiveWorkbook.SaveAs Filename:=fileSaveName _
, FileFormat:=xlCSV, CreateBackup:=False
Else
MsgBox "You have not chosen a valid file name ending in .csv", vbOKOnly, "File Name Error!"
End If

' Close text file
wb.Close

End Sub

 

[shinigamilight]

Sorry I wasn't able to get back to you earlier. Give this a try.
Run it from the sheet you're trying to export. a input box will pop up and select every column, this will only export the visible columns.

Sub Column_Visible()
        Dim rng As Range
        Set rng = Application.InputBox(Prompt:="Enter your range", Default:=Selection.Address, Type:=8)
        Dim wk As Worksheet
        Dim lc, lr As Long
        Set wk = Workbooks.Add.Sheets(1)
        Dim fName As String
        Dim fileSaveName As String
        fName = "BWSCL" & " " & Format(Now(), "DD-MMM-YY") & ".csv"
       
        For Each Column In rng.Columns
            If Column.Hidden = False Then
                Column.Copy
               lc = wk.Cells(4, Columns.Count).End(xlToLeft).Offset(0, 1).Column
               wk.Cells(1, lc).PasteSpecial xlPasteValues
            End If
        Next Column
       
        With wk
        .Range("A:A").EntireColumn.Delete
        .Range("A1:A3").EntireRow.Delete
        End With
         
        With wk
        lc = .Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Column
        .Cells(1, lc) = "EOF"
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        .Range(.Cells(2, lc), .Cells(lr, lc)) = "X"
        End With
       
       
        fileSaveName = Application.GetSaveAsFilename(fName, _
        fileFilter:="CSV (Comma delimited)(*.csv), *.csv")
       
      
        If Right(fileSaveName, 4) = ".csv" Then
        ActiveWorkbook.SaveAs Filename:=fileSaveName _
        , FileFormat:=xlCSV, CreateBackup:=False
        Else
        MsgBox "You have not chosen a valid file name ending in .csv", vbOKOnly, "File Name Error!"
        End If
       
        ActiveWorkbook.Close True
       
End Sub

 

[SteynBS]

Sorry I wasn't able to get back to you earlier. Give this a try.
Run it from the sheet you're trying to export. a input box will pop up and select every column, this will only export the visible columns.

Sub Column_Visible()
        Dim rng As Range
        Set rng = Application.InputBox(Prompt:="Enter your range", Default:=Selection.Address, Type:=8)
        Dim wk As Worksheet
        Dim lc, lr As Long
        Set wk = Workbooks.Add.Sheets(1)
        Dim fName As String
        Dim fileSaveName As String
        fName = "BWSCL" & " " & Format(Now(), "DD-MMM-YY") & ".csv"
      
        For Each Column In rng.Columns
            If Column.Hidden = False Then
                Column.Copy
               lc = wk.Cells(4, Columns.Count).End(xlToLeft).Offset(0, 1).Column
               wk.Cells(1, lc).PasteSpecial xlPasteValues
            End If
        Next Column
      
        With wk
        .Range("A:A").EntireColumn.Delete
        .Range("A1:A3").EntireRow.Delete
        End With
        
        With wk
        lc = .Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Column
        .Cells(1, lc) = "EOF"
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        .Range(.Cells(2, lc), .Cells(lr, lc)) = "X"
        End With
      
      
        fileSaveName = Application.GetSaveAsFilename(fName, _
        fileFilter:="CSV (Comma delimited)(*.csv), *.csv")
      
     
        If Right(fileSaveName, 4) = ".csv" Then
        ActiveWorkbook.SaveAs Filename:=fileSaveName _
        , FileFormat:=xlCSV, CreateBackup:=False
        Else
        MsgBox "You have not chosen a valid file name ending in .csv", vbOKOnly, "File Name Error!"
        End If
      
        ActiveWorkbook.Close True
      
End Sub

Thank you for your time and efforts in assisting me. I appreciate your assistance.

code is working, it is just copying hidden rows. I made a few changes to the code to accommodate my needs. (highlighted in red)

Sub Column_Visible()
Dim rng As Range
Set rng = Application.InputBox(Prompt:="Enter your range", Default:=Selection.Address, Type:=8)
Dim wk As Worksheet
Dim lc, lr As Long
Set wk = Workbooks.Add.Sheets(1)
Dim fName As String
Dim fileSaveName As String
fName = "BWSCL" & " " & Format(Now(), "DD-MMM-YY") & ".csv"

For Each Column In rng.Columns
If Column.Hidden = False Then
Column.Copy
lc = wk.Cells(4, Columns.Count).End(xlToLeft).Offset(0, 1).Column
wk.Cells(1, lc).PasteSpecial xlPasteValues
End If
Next Column

With wk
.Range("A:A").EntireColumn.Delete
End With

With wk
lc = .Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Column
.Cells(1, lc) = "EOF"
.Cells(1, 1) = "MATNR"
.Cells(1, 2) = "WERKS"
lr = .Range("A" & Rows.Count).End(xlUp).Row
.Range(.Cells(2, lc), .Cells(lr, lc)) = "X"
End With


fileSaveName = Application.GetSaveAsFilename(fName, _
fileFilter:="CSV (Comma delimited)(*.csv), *.csv")


If Right(fileSaveName, 4) = ".csv" Then
ActiveWorkbook.SaveAs Filename:=fileSaveName _
, FileFormat:=xlCSV, CreateBackup:=False
Else
MsgBox "You have not chosen a valid file name ending in .csv", vbOKOnly, "File Name Error!"
End If

ActiveWorkbook.Close True

End Sub

Below is a picture of my table before any filters or columns are hidden.

This is the data I want copied:

This is what I get after I run the VBA

Only rows 5 and 7 needed to be copied, but it copied row 6 as well but for some reason did not copy rows 8 and 9.

If you can help me to sort this out. For the VBA to copy the visible rows I will be ever grateful. Thank you

 

[shinigamilight]

This one is slower than before so be patient if it takes time.

Sub Column_Visible_2()
        Dim rng As Range
        Set rng = Application.InputBox(Prompt:="Enter your range", Default:=Selection.Address, Type:=8)
        Dim wk As Worksheet
        Dim lc, lr As Long
        
        Dim fName As String
        Dim fileSaveName As String
        fName = "BWSCL" & " " & Format(Now(), "DD-MMM-YY") & ".csv"
        
        Application.ScreenUpdating = False
        Set wk = Workbooks.Add.Sheets(1)
        For Each Column In rng.Columns
            If Column.Hidden = False Then
              Column.SpecialCells(xlCellTypeVisible).Copy
               lc = wk.Cells(4, Columns.Count).End(xlToLeft).Offset(0, 1).Column
               wk.Cells(1, lc).PasteSpecial xlPasteValues
            End If
        Next Column
       
        
        
        With wk
        .Range("A:A").EntireColumn.Delete
        .Range("A1:A3").EntireRow.Delete
        End With
         
        With wk
        .Cells(1, 1) = "MATNR"
        .Cells(1, 2) = "WERKS"
        lc = .Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Column
        .Cells(1, lc) = "EOF"
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        .Range(.Cells(2, lc), .Cells(lr, lc)) = "X"
        End With
       
       Application.ScreenUpdating = True
        
        fileSaveName = Application.GetSaveAsFilename(fName, _
        fileFilter:="CSV (Comma delimited)(*.csv), *.csv")
       
      
        If Right(fileSaveName, 4) = ".csv" Then
        ActiveWorkbook.SaveAs Filename:=fileSaveName _
        , FileFormat:=xlCSV, CreateBackup:=False
        Else
        MsgBox "You have not chosen a valid file name ending in .csv", vbOKOnly, "File Name Error!"
        End If
       
        ActiveWorkbook.Close True
       
End Sub

 

[SteynBS]

This one is slower than before so be patient if it takes time.

Sub Column_Visible_2()
        Dim rng As Range
        Set rng = Application.InputBox(Prompt:="Enter your range", Default:=Selection.Address, Type:=8)
        Dim wk As Worksheet
        Dim lc, lr As Long
      
        Dim fName As String
        Dim fileSaveName As String
        fName = "BWSCL" & " " & Format(Now(), "DD-MMM-YY") & ".csv"
      
        Application.ScreenUpdating = False
        Set wk = Workbooks.Add.Sheets(1)
        For Each Column In rng.Columns
            If Column.Hidden = False Then
              Column.SpecialCells(xlCellTypeVisible).Copy
               lc = wk.Cells(4, Columns.Count).End(xlToLeft).Offset(0, 1).Column
               wk.Cells(1, lc).PasteSpecial xlPasteValues
            End If
        Next Column
     
      
      
        With wk
        .Range("A:A").EntireColumn.Delete
        .Range("A1:A3").EntireRow.Delete
        End With
       
        With wk
        .Cells(1, 1) = "MATNR"
        .Cells(1, 2) = "WERKS"
        lc = .Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Column
        .Cells(1, lc) = "EOF"
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        .Range(.Cells(2, lc), .Cells(lr, lc)) = "X"
        End With
     
       Application.ScreenUpdating = True
      
        fileSaveName = Application.GetSaveAsFilename(fName, _
        fileFilter:="CSV (Comma delimited)(*.csv), *.csv")
     
    
        If Right(fileSaveName, 4) = ".csv" Then
        ActiveWorkbook.SaveAs Filename:=fileSaveName _
        , FileFormat:=xlCSV, CreateBackup:=False
        Else
        MsgBox "You have not chosen a valid file name ending in .csv", vbOKOnly, "File Name Error!"
        End If
     
        ActiveWorkbook.Close True
     
End Sub

Hi

The code Column.SpecialCells(xlCellTypeVisible).Copy is doing something I cant explain. there is some kind of cross copy and pasting happening

 

[SteynBS]

Hi,

Code Column.SpecialCells(xlCellTypeVisible).Copy is causing some issues its not copying or pasting correctly.


This is all that is now being copied

Sorry for the inconvenience.

 

[shinigamilight]

Just upload your worksheet I'll take a look what's wrong. It's hard to figure things out from screenshots. I'm testing it with multiple hidden columns and rows, and it's working.

 

[SteynBS]

Hope I am doing this correct.

FnR Uploads.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
4	Article	Site	BWSCL	RDPRF	DISMM	EKGRP	PERKZ	Vendor	S.Org	BMC	SOS	Supply Chain Level	DATA Check
5	336734002	S010		C01				4554		BPFM01	1
6	336734002	S009	2	C01				4554		BPFM01	1
7	336734002	S029	2	SHP0				4554		BPFM01	1
8	336734002	S003	2	SP01				4554		BPFM01	1
9	336734002	S060		SP01				4554		BPFM01	1
Maintenance