code stopping

P

plost33

Well-known Member
Joined
Oct 2, 2008
Messages
866
i have the following coe that works great. problem is it is stopping after only 77 rows instead of after 334. i=334 when the code runs, so i dont knwo why it is stopping. all i can think of is that it have something to do witht he fact that the folder i am putting ther files in get too full or something?? anyone see any probelms?

Code: 
Sub CompleteForms()
Dim Vendor As String
Dim Vendor1 As String
Dim CurrentRow As String
Dim CurrentColumn As Long
Dim PasteRangeName As String
Dim XXX As String
Dim Edate As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
    i = Sheets("data").Range("A2").End(xlDown).Row
    
     For Each cell In Sheets("data").Range("A2:R" & i)
        On Error Resume Next
        
        CurrentRow = cell.Row
        CurrentColumn = cell.Column
        
        If CurrentColumn = 1 Then
        
            Sheets("Template").Visible = True
            Sheets("Template").Copy After:=Sheets(2)
            Vendor1 = Sheets("Data").Range("B" & CurrentRow)
            Vendor = Left(Vendor1, 12)
            Sheets("Template (2)").Name = Vendor
                        
        Else
        End If
        
        
        PasteRangeName = Sheets("data").Cells(1, CurrentColumn).Value
        
        cell.Copy
        Sheets(Vendor).Range(PasteRangeName).PasteSpecial xlValue
        
        
        If CurrentColumn = 18 Then ' 18 is column R
        
            Edate = Sheets(Vendor).Range(Edate).Value
            XXX = Format(Edate, "[$-409]ddmmmyyyy;@")
            
            Folder = "C:\Users\tphythian\Documents\Vendor Evaluations"
            ThisWorkbook.Worksheets(Vendor).Copy
            
                With ActiveSheet.UsedRange
                    .Value = .Value
                End With
                
                With ActiveWorkbook
                    .SaveAs Folder & "\" & Vendor & " - " & XXX & ".xlsx"
                    .Close
                End With
                
            Sheets(Vendor).Delete
                
       Else
       End If
       
    Next
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Worksheets("Template").Visible = False
    
    MsgBox "All Vendor Evaluations have been created and saved in the Vendor Evaluations folder!"
       
End Sub
 
Sort by date Sort by votes
To be thorough, you should test your file names for any invalid characters (not just /) before trying to save. Don't have a handy list of invalid characters, you'll need to poke around Windows data for that.

You can use the REPLACE function to turn them into valid characters, or just delete them.
 
Upvote 0

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.
i want to add the following line like you had before to all the copied data.


so i need to assign the cell value to a variable instead of "cell.copy"

then i want to run the following line of code to clean it up...same as you should me how on the vendor name.
Code: 
Vendor = Left(Sheets("Data").Range("B" & CurrentRow), 31)
            If InStr(Vendor, "/") Then Vendor = Left(Vendor, InStr(Vendor, "/") - 1)
            If InStr(Vendor, "  ") Then Vendor = Left(Vendor, InStr(Vendor, "  ") - 1)
            If InStr(Vendor, ":") Then Vendor = Left(Vendor, InStr(Vendor, ":") - 1)

"Vendor" should be changed to the new variable. Then my line of code that say pste values only needs to say paste in values only but of the variable.

here is my entire code as it sits now:

Code: 
Sub CompleteForms()
Dim Vendor As String
Dim Vendor1 As String
Dim CurrentRow As String
Dim CurrentColumn As Long
Dim PasteRangeName As String
Dim XXX As String
Dim Edate As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
    i = Sheets("data").Range("A2").End(xlDown).Row
    
     For Each cell In Sheets("data").Range("A2:R" & i)
      
        
        CurrentRow = cell.Row
        CurrentColumn = cell.Column
        
        If CurrentColumn = 1 Then
        
            Sheets("Template").Visible = True
            Sheets("Template").Copy After:=Sheets(2)
            Vendor = Left(Sheets("Data").Range("B" & CurrentRow), 31)
            If InStr(Vendor, "/") Then Vendor = Left(Vendor, InStr(Vendor, "/") - 1)
            If InStr(Vendor, "  ") Then Vendor = Left(Vendor, InStr(Vendor, "  ") - 1)
            If InStr(Vendor, ":") Then Vendor = Left(Vendor, InStr(Vendor, ":") - 1)
            Sheets("Template (2)").Name = Vendor
                        
        Else
        End If
        
        
        PasteRangeName = Sheets("data").Cells(1, CurrentColumn).Value
        
        cell.Copy
        Sheets(Vendor).Range(PasteRangeName).PasteSpecial xlValue
        
        
        If CurrentColumn = 18 Then '18 is column R
        
                    
            Edate = Sheets(Vendor).Range("DateofEvaluation").Value
            XXX = Format(Edate, "[$-409]ddmmmyyyy;@")
            
            Folder = "C:\Users\tphythian\Documents\Vendor Evaluations"
            ThisWorkbook.Worksheets(Vendor).Copy
            
                With ActiveSheet.UsedRange
                    .Value = .Value
                End With
                
                With ActiveWorkbook
                    .SaveAs Folder & "\" & Vendor & " - " & XXX & ".xlsx"
                    .Close
                End With
                
            Sheets(Vendor).Delete
                
       Else
       End If
       
    Next
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Worksheets("Template").Visible = False
    
    MsgBox "All Vendor Evaluations have been created and saved in the Vendor Evaluations folder!"
       
End Sub
 
Upvote 0
here is what i have so far:
Rich (BB code): 
Sub CompleteForms()

Dim CopyData As String
Dim Vendor As String
Dim Vendor1 As String
Dim CurrentRow As String
Dim CurrentColumn As Long
Dim PasteRangeName As String
Dim XXX As String
Dim Edate As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
    i = Sheets("data").Range("A2").End(xlDown).Row
    
     For Each cell In Sheets("data").Range("A2:R" & i)
      
        
        CurrentRow = cell.Row
        CurrentColumn = cell.Column
        
        If CurrentColumn = 1 Then
        
            Sheets("Template").Visible = True
            Sheets("Template").Copy After:=Sheets(2)
            Vendor = Left(Sheets("Data").Range("B" & CurrentRow), 31)
            If InStr(Vendor, "/") Then Vendor = Left(Vendor, InStr(Vendor, "/") - 1)
            If InStr(Vendor, "  ") Then Vendor = Left(Vendor, InStr(Vendor, "  ") - 1)
            If InStr(Vendor, ":") Then Vendor = Left(Vendor, InStr(Vendor, ":") - 1)
            Sheets("Template (2)").Name = Vendor
                        
        Else
        End If
        
        
        PasteRangeName = Sheets("data").Cells(1, CurrentColumn).Value
        
        CopyData = cell.Value
            If InStr(CopyData, "/") Then CopyData = Left(CopyData, InStr(CopyData, "/") - 1)
            If InStr(CopyData, "  ") Then CopyData = Left(CopyData, InStr(CopyData, "  ") - 1)
            If InStr(CopyData, ":") Then CopyData = Left(CopyData, InStr(CopyData, ":") - 1)
        CopyData = cell.Copy
        
                
        Sheets(Vendor).Range(PasteRangeName).PasteSpecial xlValue
        
        
        If CurrentColumn = 18 Then '18 is column R
        
                    
            Edate = Sheets(Vendor).Range("DateofEvaluation").Value
            XXX = Format(Edate, "[$-409]ddmmmyyyy;@")
            
            Folder = "C:\Users\tphythian\Documents\Vendor Evaluations"
            ThisWorkbook.Worksheets(Vendor).Copy
            
                With ActiveSheet.UsedRange
                    .Value = .Value
                End With
                
                With ActiveWorkbook
                    .SaveAs Folder & "\" & Vendor & " - " & XXX & ".xlsx"
                    .Close
                End With
                
            Sheets(Vendor).Delete
                
       Else
       End If
       
    Next
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Worksheets("Template").Visible = False
    
    MsgBox "All Vendor Evaluations have been created and saved in the Vendor Evaluations folder!"
       
End Sub


the part i am working on is in red
 
Upvote 0
okay so i about have it now...how do i say what this tries to say:

Sheets(Vendor).Range(PasteRangeName).PasteSpecial xlValue.CopyData



i want to paste in the values only of the variable "CopyData"
 
Upvote 0
Code: 
        CopyData = cell.Value
            If InStr(CopyData, "/") Then CopyData = Left(CopyData, InStr(CopyData, "/") - 1)
            If InStr(CopyData, "  ") Then CopyData = Left(CopyData, InStr(CopyData, "  ") - 1)
            If InStr(CopyData, ":") Then CopyData = Left(CopyData, InStr(CopyData, ":") - 1)
                
        Sheets(Vendor).Range(PasteRangeName).Value = CopyData
 
Upvote 0
You must log in or register to reply here.

Similar threads

Q
  • Solved
How to stop InputBox from looping after input?
Replies
7
Views
481
qplsn9
Q
F
  • Solved
How to make loop stop when the cell is empty? (VBA)
Replies
3
Views
298
kvsrinivasamurthy
K
I
  • Question Question
File is allready saved but code should be stopping duplicates being saved
Replies
5
Views
292
ipbr21054
I
S
  • Solved
Gathering Data From Multiple Files in Same Folder in Particular Range
9 10 11
Replies
105
Views
2K
shah0101
S
I
  • Question Question
Error "Unable to set the Name property of the PivotTable class"
Replies
1
Views
275
RoryA
RoryA

Forum statistics

Threads
1,224,603
Messages
6,179,850
Members
452,948
Latest member
UsmanAli786

Share this page

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
Back
Top