SimonGeoghegan
Board Regular
- Joined
- Nov 5, 2013
- Messages
- 68
Hi All,
I have been amending some code which filters data from various tabs of a master spreadsheet, and copies and pastes these tabs into a new spreadsheet per department.
The code I have (admittedly it was existing code which I have been able to manipulate to suit my needs) currently copies and pastes this data with the department filter applied, however, I want to cut this data instead for 2 reasons:
1) Data Protection - It is important that the individual spreadsheets per department does not contain the data about the other departments (which it does currently when the filter is removed)
2) File Size - it will dramatically reduce the file size of each individual departments spreadsheet.
The code I have is as follows, but I'm struggling to understand where I can change it so that it will cut and paste, rather than copy.
Each individual tab that is copied over has its own section below, where you can see the filter applying. I have then highlighted in red where the the code appears to create the new workbook. I had hoped I could just change 'copy' to 'cut' but alas, not as straight forwards
Any help would be greatly appreciated - and thanks in advance!
Regards,
Simon
I have been amending some code which filters data from various tabs of a master spreadsheet, and copies and pastes these tabs into a new spreadsheet per department.
The code I have (admittedly it was existing code which I have been able to manipulate to suit my needs) currently copies and pastes this data with the department filter applied, however, I want to cut this data instead for 2 reasons:
1) Data Protection - It is important that the individual spreadsheets per department does not contain the data about the other departments (which it does currently when the filter is removed)
2) File Size - it will dramatically reduce the file size of each individual departments spreadsheet.
The code I have is as follows, but I'm struggling to understand where I can change it so that it will cut and paste, rather than copy.
Each individual tab that is copied over has its own section below, where you can see the filter applying. I have then highlighted in red where the the code appears to create the new workbook. I had hoped I could just change 'copy' to 'cut' but alas, not as straight forwards
Code:
Sub SplitData()
Dim I As Integer
Dim iCount As Integer
Dim LaCell As String
Dim myDynArray As Integer
Dim Hosp() As Integer ' declares a static array variable
Dim ACells() As String, Acells2() As String
Dim iLastrow As Integer
Dim eValue As String
Dim dtimeStamp As String
Dim xpathname As String
Dim strtext As String
Dim C As String
Dim ws As Worksheet
Dim fso
'Create the Folder to hold the Data
dtimeStamp = Format(Now, "yyyymmdd")
xpathname = "C:\Users\simon\Desktop\Data\" & dtimeStamp & "\"
Set fso = CreateObject("Scripting.FileSystemObject")
'Check if Directory Exists if it dosn`t create it
If Not fso.FolderExists(xpathname) Then
fso.CreateFolder (xpathname) 'Created files are saved here
Else
'MsgBox strDocPath & " already exists!", vbExclamation, "Folder Exists"
End If
Set fso = Nothing
' iLastrow = Cells.Find("*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
' This creates the unique list
' Sheets("Appointments").Range("B12:B5000").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
' "AV1"), Unique:=True
'GetSitesFromSQL ' Gets unique sites from SQL Server
I = 1
Sheets("Main Page").Select
Range("AV1").Select
Selection.End(xlDown).Select
LaCell = Replace(ActiveCell.Address, "$", "")
LaCell = Replace(LaCell, "AV", "")
myDynArray = CInt(LaCell)
ReDim Hosp(1 To myDynArray)
ReDim ACells(1 To myDynArray)
ReDim Acells2(1 To myDynArray)
'Load data into Array at runtime
For iCount = LBound(Hosp) To UBound(Hosp)
ACells(iCount) = Cells(I, 48).Value 'Name Code
Acells2(iCount) = Cells(I, 49).Value 'Name
I = I + 1
Next
For I = 2 To UBound(Hosp)
'Unposted Incidents Start
Sheets("Unposted Incidents").Select
Range("A6").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
'Range("F1").Value = ACells(I)
'Range("F4").Value = Acells2(I)
Sheets("Unposted Incidents").Select
Sheets("Unposted Incidents").Range("$B$6").AutoFilter Field:=2, Criteria1:=ACells(I)
Range("A6").Select
Selection.End(xlDown).Select
C = ActiveCell.Address
C = Replace(C, "$", "")
C = Replace(C, "A", "")
If CDbl(C) >= 65536 Then
Range("A6:X6").Select
Else
Range("A6:X" & C).Select
End If
Cells.Select
Cells.EntireColumn.AutoFit
'Unposted Incidents End
'Unposted Feedback Start
Sheets("Unposted Feedback").Select
Range("A6").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
'Range("F1").Value = ACells(I)
'Range("F4").Value = Acells2(I)
Sheets("Unposted Feedback").Select
Sheets("Unposted Feedback").Range("$B$6").AutoFilter Field:=5, Criteria1:=ACells(I)
Range("A6").Select
Selection.End(xlDown).Select
C = ActiveCell.Address
C = Replace(C, "$", "")
C = Replace(C, "A", "")
If CDbl(C) >= 65536 Then
Range("A6:X6").Select
Else
Range("A6:X" & C).Select
End If
Cells.Select
Cells.EntireColumn.AutoFit
'Unposted Feedback End
'Open Incidents
Sheets("Open Incidents").Select
Range("A6").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
'Range("F1").Value = ACells(I)
'Range("F4").Value = Acells2(I)
Sheets("Open Incidents").Select
Sheets("Open Incidents").Range("$B$6").AutoFilter Field:=2, Criteria1:=ACells(I)
Range("A6").Select
Selection.End(xlDown).Select
C = ActiveCell.Address
C = Replace(C, "$", "")
C = Replace(C, "A", "")
If CDbl(C) >= 65536 Then
Range("A6:Z6").Select
Else
Range("A6:Z" & C).Select
End If
Cells.Select
Cells.EntireColumn.AutoFit
'Open Incidents end
'Complaints Outstanding
Sheets("Complaints Outstanding").Select
Range("A6").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
'Range("F1").Value = ACells(I)
'Range("F4").Value = Acells2(I)
Sheets("Complaints Outstanding").Select
Sheets("Complaints Outstanding").Range("$B$6").AutoFilter Field:=2, Criteria1:=ACells(I)
Range("A6").Select
Selection.End(xlDown).Select
C = ActiveCell.Address
C = Replace(C, "$", "")
C = Replace(C, "A", "")
If CDbl(C) >= 65536 Then
Range("A6:L6").Select
Else
Range("A6:L" & C).Select
End If
Cells.Select
Cells.EntireColumn.AutoFit
'Complaints Outstanding End
'Incorrectly Closed Incidents Start
Sheets("Incorrectly Closed Incidents").Select
Range("A6").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
'Range("F1").Value = ACells(I)
'Range("F4").Value = Acells2(I)
Sheets("Incorrectly Closed Incidents").Select
Sheets("Incorrectly Closed Incidents").Range("$B$6").AutoFilter Field:=2, Criteria1:=ACells(I)
Range("A6").Select
Selection.End(xlDown).Select
C = ActiveCell.Address
C = Replace(C, "$", "")
C = Replace(C, "A", "")
If CDbl(C) >= 65536 Then
Range("A6:L6").Select
Else
Range("A6:L" & C).Select
End If
Cells.Select
Cells.EntireColumn.AutoFit
'Incorrectly Closed Incidents End
'Missing Complaint Status Start
Sheets("Missing Complaint Status").Select
Range("A6").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
'Range("F1").Value = ACells(I)
'Range("F4").Value = Acells2(I)
Sheets("Missing Complaint Status").Select
Sheets("Missing Complaint Status").Range("$B$6").AutoFilter Field:=2, Criteria1:=ACells(I)
Range("A6").Select
Selection.End(xlDown).Select
C = ActiveCell.Address
C = Replace(C, "$", "")
C = Replace(C, "A", "")
If CDbl(C) >= 65536 Then
Range("A6:X6").Select
Else
Range("A6:X" & C).Select
End If
Cells.Select
Cells.EntireColumn.AutoFit
'Missing LTI Start
Sheets("Missing LTI Data").Select
Range("A6").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
'Range("F1").Value = ACells(I)
'Range("F4").Value = Acells2(I)
Sheets("Missing LTI Data").Select
Sheets("Missing LTI Data").Range("$B$6").AutoFilter Field:=2, Criteria1:=ACells(I)
Range("A6").Select
Selection.End(xlDown).Select
C = ActiveCell.Address
C = Replace(C, "$", "")
C = Replace(C, "A", "")
If CDbl(C) >= 65536 Then
Range("A6:X6").Select
Else
Range("A6:X" & C).Select
End If
Cells.Select
Cells.EntireColumn.AutoFit
'End of LTI
'Missing RIDDOR Start
Sheets("Missing RIDDOR Ref").Select
Range("A6").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
'Range("F1").Value = ACells(I)
'Range("F4").Value = Acells2(I)
Sheets("Missing RIDDOR Ref").Select
Sheets("Missing RIDDOR Ref").Range("$C$6").AutoFilter Field:=3, Criteria1:=ACells(I)
Range("A6").Select
Selection.End(xlDown).Select
C = ActiveCell.Address
C = Replace(C, "$", "")
C = Replace(C, "A", "")
If CDbl(C) >= 65536 Then
Range("A6:X6").Select
Else
Range("A6:X" & C).Select
End If
Cells.Select
Cells.EntireColumn.AutoFit
'End of RIDDOR
'Incomplete Investigations Start
Sheets("Incomplete Investigations").Select
Range("A6").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
'Range("F1").Value = ACells(I)
'Range("F4").Value = Acells2(I)
Sheets("Incomplete Investigations").Select
Sheets("Incomplete Investigations").Range("$C$6").AutoFilter Field:=3, Criteria1:=ACells(I)
Range("A6").Select
Selection.End(xlDown).Select
C = ActiveCell.Address
C = Replace(C, "$", "")
C = Replace(C, "A", "")
If CDbl(C) >= 65536 Then
Range("A6:X6").Select
Else
Range("A6:X" & C).Select
End If
Cells.Select
Cells.EntireColumn.AutoFit
'End of Incomplete Investigations
'Incomplete Investigations Start
Sheets("Missing Patient Details").Select
Range("A6").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
'Range("F1").Value = ACells(I)
'Range("F4").Value = Acells2(I)
Sheets("Missing Patient Details").Select
Sheets("Missing Patient Details").Range("$B$6").AutoFilter Field:=2, Criteria1:=ACells(I)
Range("A6").Select
Selection.End(xlDown).Select
C = ActiveCell.Address
C = Replace(C, "$", "")
C = Replace(C, "A", "")
If CDbl(C) >= 65536 Then
Range("A6:X6").Select
Else
Range("A6:X" & C).Select
End If
Cells.Select
Cells.EntireColumn.AutoFit
'End of Incomplete Investigations
'Start of Save the temp Sheets into folders
[COLOR=#FF0000][B] Sheets(Array("Main Page", "Unposted Incidents", "Unposted Feedback", "Open Incidents", "Complaints Outstanding", "Incorrectly Closed Incidents", "Missing Complaint Status", "Missing LTI Data", "Missing RIDDOR Ref", "Incomplete Investigations", "Missing Patient Details")).Copy
Sheets(Array("Main Page", "Unposted Incidents", "Unposted Feedback", "Open Incidents", "Complaints Outstanding", "Incorrectly Closed Incidents", "Missing Complaint Status", "Missing LTI Data", "Missing RIDDOR Ref", "Incomplete Investigations", "Missing Patient Details")).Select[/B][/COLOR]
Sheets("Main Page").Select
Range("A1").Select
Sheets("Unposted Incidents").Select
Range("A1").Select
Sheets("Unposted Feedback").Select
Range("A1").Select
Sheets("Open Incidents").Select
Range("A1").Select
Sheets("Complaints Outstanding").Select
Range("A1").Select
Sheets("Incorrectly Closed Incidents").Select
Range("A1").Select
Sheets("Missing Complaint Status").Select
Range("A1").Select
Sheets("Missing LTI Data").Select
Range("A1").Select
Sheets("Incomplete Investigations").Select
Range("A1").Select
Sheets("Missing Patient Details").Select
Range("A1").Select
Sheets("Main Page").Select
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs filename:= _
xpathname & "RiskMan DQ - " & ACells(I) & " " & dtimeStamp & ".xls", FileFormat:=xlNormal, _
password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
'ActiveWorkbook.Save
ActiveWorkbook.Close
Application.DisplayAlerts = True
Next
'Tidy up
For Each ws In Sheets(Array("Unposted Incidents", "Unposted Feedback", "Open Incidents", "Complaints Outstanding", "Incorrectly Closed Incidents", "Missing Complaint Status"))
ws.Select
Selection.AutoFilter
Cells(1, 1).Select
Sheets("Main Page").Select
Range("A1").Select
Next ws
'MsgBox "All Done", vbInformation
'Erase MyNames() ' deletes the varible contents, free some memory
End SubAny help would be greatly appreciated - and thanks in advance!
Regards,
Simon
