Hi,
I've got my macro sorted, just today there was another bit I had to add to my code, and this is where it fails. Tried to sort it out for few hours but no luck.
What's wrong with the code? The bit in bold, everything else is fine without it.
Would also appreciate if someone could instruct me how to clean up my code a bit
Thanks, any help appreciated.
I've got my macro sorted, just today there was another bit I had to add to my code, and this is where it fails. Tried to sort it out for few hours but no luck.
What's wrong with the code? The bit in bold, everything else is fine without it.
Would also appreciate if someone could instruct me how to clean up my code a bit
Code:
Sub client_date_single()Dim main, index As Worksheet
Dim tname As String
Dim last_c, cel, rng, rng_last As Range
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.CopyObjectsWithCells = False
Set main = Sheets("MAIN (FORMULAS)")
Set index = Sheets("Index")
tname = ThisWorkbook.Path
With index
date1 = DateValue(Range("B2"))
client = Range("A2")
date3 = Range("B2")
End With
'create new main file with values only
Set newb_main = Workbooks.Add
With newb_main
With .Sheets.Add(Before:=.Sheets(1))
.Name = "ALL VALUES"
End With
End With
newb_main.SaveAs Filename:=tname & "\" & "ALL"
With Workbooks("ALL")
.Sheets("Sheet1").Delete
.Sheets("Sheet2").Delete
.Sheets("Sheet3").Delete
End With
'create new sales file with values
Set newb_sales = Workbooks.Add
With newb_sales
With .Sheets.Add(Before:=.Sheets(1))
.Name = "SALES"
End With
End With
newb_sales.SaveAs Filename:=tname & "\" & "SALESR"
With Workbooks("SALESR")
.Sheets("Sheet1").Delete
.Sheets("Sheet2").Delete
.Sheets("Sheet3").Delete
End With
'copy over data to new file values only
main.Range("A1:R10000").Copy
With newb_main.Sheets("ALL VALUES")
.Range("A1").PasteSpecial xlPasteValues
.Range("A1").PasteSpecial xlPasteFormats
.Columns("A:R").AutoFit
.Range("S1:AZ10000").Clear
.Range("A1:R1").AutoFilter
End With
newb_main.Save
'filter data i need with newly created file with values only
With newb_main.Sheets("ALL VALUES").Range("A1:R10000")
.AutoFilter 2, "=" & client
.AutoFilter 12, "=" & date1
.SpecialCells(xlVisible).Copy
End With
'creating new file with name of client choosen
Set newbook = Workbooks.Add
With newbook
With .Sheets.Add(Before:=.Sheets(1))
.Name = client
End With
End With
' this client required deleting of one of the data columns
If index.Range("A2").Value = "CLARITY USP" Then
With newbook.Worksheets(client)
.Range("A1").PasteSpecial xlPasteValues
.Range("A1").PasteSpecial xlPasteFormats
.Columns("A:R").AutoFit
.Range("S1:AZ6666").Clear
.Columns(4).EntireColumn.Delete
End With
Else
With newbook.Worksheets(client)
.Range("A1").PasteSpecial xlPasteValues
.Range("A1").PasteSpecial xlPasteFormats
.Columns("A:R").AutoFit
.Range("S1:AZ6666").Clear
End With
End If
'saving the client report
newbook.SaveAs Filename:=tname & "\" & client
With Workbooks(client)
.Sheets("Sheet1").Delete
.Sheets("Sheet2").Delete
.Sheets("Sheet3").Delete
.Save
'test if data found
count1 = .Sheets(client).Range("A1:A100").Cells.SpecialCells(xlCellTypeConstants).Count
End With
If count1 = 1 Then
MsgBox ("No data found for " & client & " - with dispatch date: " & date3)
Workbooks(client).Save
newb_main.Close SaveChanges:=True
Kill tname & "\" & client & ".xlsx"
Kill tname & "\ALL.xlsx"
Exit Sub
End If
'end test
'TESTING - PULLING PRODUCT LINES over to different sheets on client report
'picking range to loop through for all invoice nubmers found
With Workbooks(client).Sheets(client)
Set rng_last = .Range("D2").End(xlDown)
Set rng = .Range("D2", rng_last)
End With
'copying over the values only to new file for sales
With ThisWorkbook.Sheets("Sales Report")
.Range("A1:N10000").Copy
End With
With Workbooks("SALESR").Sheets("SALES")
.Range("A1").PasteSpecial xlPasteValues
.Range("A1").PasteSpecial xlPasteFormats
End With
'loop through all the cells with invoices in the client file, add the sheet named after current cell in range value, and pasting the values from filtered sales report to each sheet
[B] On Error Resume Next[/B]
[B] For Each cel In rng.Cells[/B]
[B] 'With cel[/B]
[B] With Workbooks(client)[/B]
[B] With .Sheets.Add(After:=.Sheets(1))[/B]
[B] .Name = cel[/B]
[B] End With[/B]
[B] End With[/B]
[B] With Workbooks("SALESR").Sheets("SALES")[/B]
[B] .Range("A1:N10000").AutoFilter 10, cel[/B]
[B] .Range("A1:N10000").SpecialCells(xlVisible).Copy[/B]
[B] .Range("A1:N10000").Select[/B]
[B] .Selection.Copy[/B]
[B] '.Range("A1:N1").AutoFilter[/B]
[B] '.Range("A1:N1").AutoFilter[/B]
[B] End With[/B]
[B] With Workbooks(client).Sheets(cel).Range("A1")[/B]
[B] .PasteSpecial xlPasteValues[/B]
[B] .PasteSpecial xlPasteFormats[/B]
[B] End With[/B]
[B] 'End With[/B]
[B] On Error Resume Next[/B]
[B] Next cel[/B]
Workbooks("SALESR").Close SaveChanges:=True
Workbooks(client).Close SaveChanges:=True
newb_main.Sheets("ALL VALUES").Range("A1:r1").AutoFilter
newb_main.Sheets("ALL VALUES").Range("A1:r1").AutoFilter
newb_main.Close SaveChanges:=True
Kill tname & "\ALL.xlsx"
Kill tname & "\SALESR.xlsx"
On Error GoTo 0
Application.ScreenUpdating = True
Application.CopyObjectsWithCells = True
Application.CutCopyMode = False
Application.DisplayAlerts = True
End SubThanks, any help appreciated.
