CODEWITHSUNDEEP
vbaexcel
osbourne.cox
osbourne.cox

Reputation: 1

Loop through Workbook to Create New Workbooks and Save them With Cell Value as Title Else Copy/Paste to Existing Workbook

I have an Excel workbook with a list of dates and names. The workbook has 500 rows. The date is in Column A and the names are in Column B. The date is the same for all 500 rows in the workbook, each name is unique.

My goal is to ultimately end up with a number of workbooks, saved according to their name in a separate directory. Each workbook will have the same headers (Col A: date, Col B: name), with rows ranked according to date in column A.

I have other workbooks with varying numbers of rows but with the same columns.

  1. Read through Column B, check if a file with value in Cell B2 exists.

  2. If a file with value in Cell B2 does not exist, copy row, create a file with name of value in Cell B2 with headers in Row1, paste row and save as name of value in Cell B2 of new sheet.

  3. If file with value in Cell B2 (e.g. David) already exists, copy entire row, open that file, paste row (containing date) to the first available blank row. (I had wanted to insert row based on date value but was unable to do so and will sort data according to headers)

The workbook new workbook creation, copying, pasting naming and works fine.

The issue I'm experiencing is that the procedure seems to ignore the first If statement, causing excel to give the question: "File with name David exists in this location, do you want to overwrite it?"

Below is what I have done so far, if I'm not clear enough, please let me know, any help is sincerely appreciated:

Option Explicit  
Sub CreateNewWorkBook()  
    Dim ThisPath As String  
    Dim ActivePath As String  
    Dim rRange As Range  
    Dim rCell As Range  
    Application.ScreenUpdating = False  
    ThisPath = ThisWorkbook.Path  
    ActivePath = ActiveWorkbook.Path  
    Set File1 = ThisWorkbook  
    Set File2 = ActiveWorkbook  
    Set rRange = Range("B2", Range("B655365").End(xlUp))  
    Set rCell = cell.Value  
For Each rCell In rRange.Cells  
    If Dir(ThisPath & "\" & "Names" & "\" & rCell) = "" Then  
    rCell.EntireRow.Copy  
    Workbooks.Add  
    Range("2:2").PasteSpecial xlPasteAll  
    ActiveWorkbook.SaveAs Filename:=ThisPath & "\" & "Names" & "\" & Range("B2").Value  
    Range("A1").Value = "Date"  
    Range("B1").Value = "Name"  
    ActiveWorkbook.Close SaveChanges:=True  
Else: rCell.EntireRow.Copy  
    Workbooks.Open Filename:=(ThisPath & "\" & "Names" & " \ " & "rCell")  
    UsedRange.Columns(1).Offset(1, 0).PasteSpecial xlPasteValues  
    ActiveWorkbook.Close SaveChanges:=True  
    End If  
    Next rCell  
    Exit For  
    End Sub

Upvotes: 0

Views: 2609

Answers (1)

ARich
ARich

Reputation: 3279

The problem seems to be that your If statement is looking for a folder, not a file. Unless your column of names includes file extensions, you haven't given your If statement enough information to check for a file.

The path you're feeding your If statement looks like this:

"C:\Users\Workbook Folder\Names\Joe Smith"

Since there isn't a file extension, the If statement thinks "Joe Smith" is a folder.

To fix this, you can add a file extension to your code like this:

If Dir(ThisPath & "\" & "Names" & "\" & rCell & ".xls*") = "" Then

Note the use of a wildcard to check for all file extensions that begin with ".xls".

Upvotes: 0

Related Questions