Copy every 3 columns to a new worksheet

ian.cook

New Member
Joined
Sep 8, 2012
Messages
16
Office Version
  1. 2007
Platform
  1. Windows
Hello everyone,

I would greatly appreciate some assistance with a simple code I cobbled together and works well. It consists of two macros. The first one copies single columns to a new sheet in the workbook. The second macro exports the created sheets as separate csv files. I would like to extend this so that I can export every three columns to a new sheet, so that I can create separate csv files containing these three columns. Here's an image of a worksheet with the column format.
SampleData.png


VBA Code:
Sub ColsToSheets()
    Dim sh As Worksheet, sh1 As String, i As Long
    sh1 = ActiveSheet.Name
    Application.ScreenUpdating = False
    For i = 1 To 263    '<---- currently for first 263 columns. Change as required
    If Not Evaluate("isref(" & Sheets(sh1).Cells(1, i).Value & "!A1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = Sheets(sh1).Cells(1, i).Value
        With Sheets(sh1)
            .Range(.Cells(1, i), .Cells(.Cells(.Rows.Count, i).End(xlUp).Row, i)).Copy ActiveSheet.Range("A1")
        End With
    Next i
    Sheets(sh1).Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub
Sub ExportSheetsToCSV()
    Dim xWs As Worksheet
    Dim xcsvFile As String
    For Each xWs In Application.ActiveWorkbook.Worksheets
        xWs.Copy
        xcsvFile = ThisWorkbook.Path & "\" & xWs.Name & ".csv"
        Application.ActiveWorkbook.SaveAs Filename:=xcsvFile, _
        FileFormat:=xlCSV, CreateBackup:=False
        Application.ActiveWorkbook.Saved = True
        Application.ActiveWorkbook.Close
    Next
End Sub

Thanks,

Ian
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
2,292
Office Version
  1. 2010
Platform
  1. Windows
have you tried changing this line:
VBA Code:
   For i = 1 To 263
to
VBA Code:
 For i = 1 To 263 step 3
 

ian.cook

New Member
Joined
Sep 8, 2012
Messages
16
Office Version
  1. 2007
Platform
  1. Windows
Thanks, tried the suggestion. Still gives me one column per sheet.
 

MARK858

MrExcel MVP
Joined
Nov 12, 2010
Messages
14,343
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
  2. Mobile
Try (untested)....
VBA Code:
 For i = 1 To 263 step 3
and
Rich (BB code):
 .Range(.Cells(1, i), .Cells(.Cells(.Rows.Count, i).End(xlUp).Row, i)).Resize(, 3).Copy ActiveSheet.Range("A1")
 

ian.cook

New Member
Joined
Sep 8, 2012
Messages
16
Office Version
  1. 2007
Platform
  1. Windows

ADVERTISEMENT

Great! Works wonderfully. I have noticed that some of my rows (within an individual i.e. 3 columns) have blank values. Likely because there was no measurement. I have tried the following on 3 columns:

Rich (BB code):
 Columns("G:I").Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.Delete Shift:=xlUp

It works well - but only for three columns at a time. I need this applied to every 3 columns before they are copied to the sheet (or as the sheets are saved to individual csv files). Here is something I tried:

Rich (BB code):
 With Columns("A:C").Select
        Selection.SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
 End With

Placed here in this module - the files are created but there is no effect on the blank cells i.e. not deleted and cells shifted up:

Rich (BB code):
Sub ExportSheetsToCSV()
    Dim xWs As Worksheet
    Dim xcsvFile As String
    For Each xWs In Application.ActiveWorkbook.Worksheets
    
    With Columns("A:C").Select
        Selection.SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
    End With
        
        xWs.Copy
        xcsvFile = ThisWorkbook.Path & "\" & xWs.Name & ".csv"
        Application.ActiveWorkbook.SaveAs Filename:=xcsvFile, _
        FileFormat:=xlCSV, CreateBackup:=False
        Application.ActiveWorkbook.Saved = True
        Application.ActiveWorkbook.Close
    Next
End Sub

Thanks for your help!
 

MARK858

MrExcel MVP
Joined
Nov 12, 2010
Messages
14,343
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
  2. Mobile
Try changing
VBA Code:
    With Columns("A:C").Select
        Selection.SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
    End With
to
VBA Code:
xWs.Columns("A:C").SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
 

ian.cook

New Member
Joined
Sep 8, 2012
Messages
16
Office Version
  1. 2007
Platform
  1. Windows
Works perfectly! Many thanks! Here's the final code for the two macro's:
Rich (BB code):
Sub ColsToSheets()
    Dim sh As Worksheet, sh1 As String, i As Long
    sh1 = ActiveSheet.Name
    Application.ScreenUpdating = False
    For i = 1 To 879 Step 3   '<---- currently for 1 to xxx columns to read, and first xxx columns (Steps) to copy and past. Change xxx as required
    If Not Evaluate("isref(" & Sheets(sh1).Cells(1, i).Value & "!A1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = Sheets(sh1).Cells(1, i).Value
        With Sheets(sh1)
            .Range(.Cells(1, i), .Cells(.Cells(.Rows.Count, i).End(xlUp).Row, i)).Resize(, 3).Copy ActiveSheet.Range("A1") '<----change Resize value to match Step value
        End With
    Next i
    Sheets(sh1).Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Sub ExportSheetsToCSV()
    Dim xWs As Worksheet
    Dim xcsvFile As String
    Application.ScreenUpdating = False
    For Each xWs In Application.ActiveWorkbook.Worksheets
        xWs.Columns("A:C").SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
        xWs.Copy
        xcsvFile = ThisWorkbook.Path & "\" & xWs.Name & ".csv"
        Application.ActiveWorkbook.SaveAs Filename:=xcsvFile, _
        FileFormat:=xlCSV, CreateBackup:=False
        Application.ActiveWorkbook.Saved = True
        Application.ActiveWorkbook.Close
    Next
End Sub
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,152,570
Messages
5,770,913
Members
425,652
Latest member
Pemby

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
Top