You are here:

Excel/Lood down column, copy data to multiple workbooks

Advertisement


Question
Hey Tom, hope you are well - I have a simple but troublesome macro that just dosnt seem to want to loop. Its driving me loopy you might say

The code is supposed to read down a column and copy data to new workbooks.

Sample data

A1

January
January
January
January
February
February
March
March
EoF

so January.xls should contain 3 rows with January in Sheet1 - A1
February.xls should contain 2 rows with February in Sheet1 -A1
March.xls should contain 2 rows with March in Sheet1 - A1

I have tried with the code below it creates a new BLANK workbook - omg. No loop and no Copy Sigh.

Any suggestions you could offer would be greatly appreciated.

Sub Newbookloop()

'This macro is supposed to read down range A1 and copy data to new workbooks

  Dim LRow As Integer
  Dim LColARange As String
  Dim LContinue As Boolean
  
  Dim wbTarget As Workbook

      'Initialize variables
  LContinue = True
  LRow = 1
   
       Dim x As String, rng As Range, cel As Range
   
  With ActiveSheet
Set rng = .Range("A1")
For Each cel In rng
x = x & cel.Value
   
    
 'Loop through all column A values until a blank cell is found
         
         While LContinue = True
         
         LRow = LRow + 1
         LColARange = "A" & CStr(LRow)
         
         Debug.Print LColARange
         
         'Found a blank cell, do not continue
         If Len(Range(LColARange).Value) = 0 Then
         LContinue = False
         End If
         
     'Found first occurrence that did not match cell A1's value
         
      If Range("A1").Value <> Range(LColARange).Value Then
         
    Debug.Print "range a1 value is" & Range("A1").Value
     Debug.Print "range lcolrange value is" & Range(LColARange).Value
         
         LContinue = False
         
         'open a workbook
         
      Range("A1").Select


         Set wbTarget = Workbooks.Add
    
         'Copy data from columns A - C
         
         'paste the data on the target book
 
  
         Range("A1:C" & CStr(LRow - 1)).Select
         Selection.Copy
         
         'Paste results to cell A1 in Sheet2
         Sheets("Sheet1").Select
         Range("A1").Select
         Range("A1").PasteSpecial
         
         MsgBox "Copy has completed."
         
     wbTarget.SaveAs Filename:="C: ilepath\" & x & ".xls"
         
         
         End If
         
         Wend
         
      Next
      
       LContinue = True

Debug.Print x
Debug.Print LRow
End With
  
End Sub

Answer
Paul,

in your example, I am assuming the "eof" is really a blank cell - so you want to stop processing when the next Month name would be a blank.  

first I would check this statement:
Filename:="C: ilepath\" & x & ".xls"

and make sure that is a correct path.  



Then I would see you code as being this which I tested and it worked for me:

Sub Newbookloop()

'This macro is supposed to read down range A1 and copy data to new workbooks

 Dim LRow As Integer
 Dim LColARange As String
 Dim LContinue As Boolean
 Dim shSrc As Worksheet
 Dim shDest As Worksheet
 
 Dim wbTarget As Workbook

     'Initialize variables
 LContinue = True
 LRow = 1
 StartRow = 1
      Dim x As String, rng As Range, cel As Range
Set shSrc = ActiveSheet

Set cel = shSrc.Range("A1")

    x = cel.Text
  
   
'Loop through all column A values until a blank cell is found
        
While LContinue = True
        
        LRow = LRow + 1
        LColARange = "A" & CStr(LRow)
        
        Debug.Print LColARange
        
        'Found a blank cell, do not continue
        
    'Found first occurrence that did not match cell A1's value
        
     If shSrc.Range("A" & StartRow).Value <> shSrc.Range(LColARange).Value Then
        
        Debug.Print "range a1 value is" & shSrc.Range("A1").Value
        Debug.Print "range lcolrange value is" & shSrc.Range(LColARange).Value
        
        
        'open a workbook
        


        Set wbTarget = Workbooks.Add
        Set shDest = wbTarget.Worksheets(1)
   
        'Copy data from columns A - C
        
        'paste the data on the target book

 
        shSrc.Range("A" & StartRow & ":C" & CStr(LRow - 1)).Copy
        
        'Paste results to cell A1 in New Workbook

        shDest.Range("A1").PasteSpecial xlValues
        
        MsgBox "Copy has completed for: " & x
        
         wbTarget.SaveAs Filename:="C: ilepath\" & x & ".xls"
         Debug.Print "Copied: " & x & " Data"
       
        x = shSrc.Range("A" & LRow).Text
        If Len(Trim(x)) = 0 Then
         LContinue = False
        Else
         StartRow = LRow
         Debug.Print "New Month: " & x & " Starting at row: " & StartRow
        End If
     End If
Wend
End Sub

--
Regards,
Tom Ogilvy

About Excel
This topic answers questions related to Microsoft Excel spreadsheet (or workbook) stand-alone or Mircrosoft Office Excel including Excel 2003, Excel 2007, Office 2000, and Office XP. You can get Excel help on Excel formulas(or functions), Excell macros, charting in Excel, advanced features, and the general use of Excel. This does not provide a general Excel tutorial nor the basics of using a spreadsheet. It provides specific answers to using Microsoft Excel only. If you do not see your Excel question answered in this area then please ask an Excel question here

Excel

All Answers


Answers by Expert:


Ask Experts

Volunteer


Tom Ogilvy

Expertise

Selected as an Excel MVP by Microsoft since 1999. Answering Excel questions in Allexperts since its inception in 2001. Able to answer questions on almost all aspects of Excel's internal capabilities. If seeking a VBA solution, please specify that in your question itself so I give you the answer you want. [Excel has weak protection - if you are distributing an application, I don't answer questions on how to protect your project from your users.]

Experience

Extensive experience.

Education/Credentials
Master of Science (MS) degree Operations Research (ORSA)

Awards and Honors
Microsoft MVP in Excel.

©2016 About.com. All rights reserved.