Sub FoodCopy1_()
' 2008.4.3 by Towa Tachibana
' This macro makes a new file with extracted columns from the sheets"LaborI" and "Labor2"
' It automatically attaches appropriate name to the new file name
' May seem stupid, but if you have a lot of similar files (labor inputs in each factory, etc)
' this is really helpful

Dim mySht1 As Worksheet, mySht2 As Worksheet
Dim sourceBook As Workbook
Dim newBook As Workbook
Dim myFileName As String
Dim myName As Range
Dim myPath As String
Dim Ly As Integer 'Number of Rows this macro examines
Dim i As Integer 'For loop in the source sheets
Dim j As Integer 'For loop in the new (copy) sheets
    


    myPath = ActiveWorkbook.Path
' you have to get the current path name before Set newBook below
' If you put this command below "Set newBook", you will get the path
' of the added workbook.
    
    Set myName = ActiveCell
' Get name of the current cell (Harvest, Plowing, etc)
  
    Set sourceBook = ActiveWorkbook
' Give name to the source (original file)


    Ly = 255
'This macro checks the flags till Column 255
' A sheet has 256 columns
'(the data in Sheet LaborI spreads from column 1 to 250)
'(the data in Shet LaborII spreads from column 1 to 199)

    j = 2
' The starting column in the copied file.  I usually start from column B

    Set mySht1 = Sheets("LaborI")
    Set mySht2 = Sheets("LaborII")
    
    Set newBook = Workbooks.Add
'Make a new file for copying
'Now you are in newBook
        
    sourceBook.Activate
'Yo have to go back to the source file
        
    For i = 1 To Ly
    
    If Cells(2, i).Value = 1 Then
'Examines the entries in Row 2 of the sheet
'Pick up the coulms with entry of "1" in Row 2

            Columns(i).Copy _
                    Destination:=newBook.Sheets("Sheet1").Columns(j)

            j = j + 1
        '  sourceBook.mySht1.Activate
    End If
            
    Next i
    
    
    mySht2.Activate
'Move to the second sheet
'If you have more than 2 sheets, copy this part


    For i = 1 To Ly
    
    If Cells(2, i).Value = 1 Then
'Examines the entries in Row 2 of the sheet
'Pick up the coulms with entry of "1" in Row 2

            Columns(i).Copy _
                    Destination:=newBook.Sheets("Sheet1").Columns(j)

            j = j + 1
        '  sourceBook.mySht1.Activate
    End If
            
    Next i

 
    
    
    
    
    myFileName = myPath & "\" & myName.Text & "2001-food-080421.xls"
' Define appropriate name for the new file here.
'        mySht1.Copy toSht1
'        mySht2.Copy toSht2
        
        
        
        
    newBook.SaveAs Filename:=myFileName
    Set newBook = Nothing
    Set mySht1 = Nothing
End Sub