Option Explicit
Public glb_origCalculationMode As Integer
Sub Creat_Workbook_FromSheetsRows()
Dim finalrow As Long, filenum As Long, shtExistNum As Long, I As Long, y As Long, x As Long
Dim xpathname As String, wkSheetName As String, newWksheetName As String
Dim lastfile As Boolean
On Error GoTo ResetSpeed
SpeedOn
With ThisWorkbook.Sheets("Download")
finalrow = .Cells(.Rows.Count, "A").End(xlUp).Row - 1
End With
Sheets("Download").Select
Range("C3").Select
Range(Cells(3, 1), Cells(finalrow, 34)).Sort Key1:=Range("C3"), Order1:=xlAscending, Key2:= _
Range("Z3"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
For I = 3 To finalrow
With ThisWorkbook.Sheets("Blank")
For x = 10 To 3 Step -1 'the code below will delete any sold from previous that appear on current worksheet
Debug.Print x
If .Cells(x, 26).Value = "S" Or .Cells(x, 26).Value = "C" Then 'if the Part Type column contains an "S" then:
.Rows(x).Delete Shift:=xlUp 'delete entire row (Sold Participation)
End If
Next x
End With
ThisWorkbook.Sheets("Download").Activate
If Cells(I, 11).Value >= 0 And Cells(I, 12).Value >= 0 Then
If Cells(I, 26).Value = "S" Or Cells(I, 26).Value = "C" Then GoTo sold 'sold goes to the next I (basically skipping the code below)
Range(Cells(I, 1), Cells(I, 34)).Copy
ThisWorkbook.Sheets("Blank").Range("A3").PasteSpecial xlAll
With ThisWorkbook.Sheets("Download") 'selects tab named "Download" in current workbook
If .Cells(I, 26).Value = "P" Or .Cells(I, 26).Value = "p" Then 'parent loan row
If .Cells(I, 4).Value = vbNullString Then GoTo NoMoreRows 'loan # row
y = .Cells(I, 4).Value 'loan # row
For x = 3 To finalrow 'start at row 3 and do every row until final row
Debug.Print x 'in the immediate box below, print what row macro is working on
If x = I Then GoTo samerow 'if the row it is working on (x) equals I (parent row), go to "samerow:" below
If .Cells(x, 27).Value = y Then 'if column AA and the row it is working on's value is equal to the parent loan #, then:
.Range(.Cells(x, 1), .Cells(x, 34)).Copy 'copy the row it is working on
Sheets("Blank").Range("A4").Insert Shift:=xlDown 'in the blank tab, add a row in place of A4
End If
samerow:
Next x
End If
NoMoreRows:
End With
ThisWorkbook.Sheets("Blank").Cells.Copy
Workbooks.Add
ActiveSheet.Cells(1, 1).PasteSpecial (xlAll)
'With Selection.Interior
' .ColorIndex = 2
' .Pattern = xlSolid
' End With
ActiveSheet.Name = ActiveSheet.Range("C3")
ActiveWorkbook.Sheets(3).Delete 'deletes extra unused worksheets
ActiveWorkbook.Sheets(2).Delete
xpathname = ThisWorkbook.Path & "\" & "Sheets" & "\" 'adds a folder called "Sheets" wherever the template in which the code is run has been saved.
If Not FileOrDirExists(xpathname) Then 'if the file name does not exist
MkDir xpathname 'name file normally
End If
wkSheetName = Trim(ActiveSheet.Name)
newWksheetName = Trim(ActiveSheet.Name)
shtExistNum = 1
lastfile = False
CheekName:
If FileOrDirExists(xpathname & newWksheetName & ".xls") Then
shtExistNum = shtExistNum + 1
newWksheetName = wkSheetName & shtExistNum
lastfile = True
GoTo CheekName
End If
If lastfile = True Then
newWksheetName = wkSheetName & shtExistNum
Else
newWksheetName = wkSheetName
End If
ActiveWorkbook.SaveAs Filename:=xpathname & newWksheetName & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", CreateBackup:=False, _
ReadOnlyRecommended:=False
ActiveWorkbook.Close
End If
sold:
Next I
ResetSpeed:
SpeedOff
End Sub
Function FileOrDirExists(PathName As String) As Boolean
Dim iTemp As Integer
On Error Resume Next
iTemp = GetAttr(PathName)
Select Case Err.Number
Case Is = 0
FileOrDirExists = True
Case Else
FileOrDirExists = False
End Select
On Error GoTo 0
End Function
Sub SpeedOn(Optional StatusBarMsg As String = "Running macro...")
glb_origCalculationMode = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Cursor = xlWait
.StatusBar = StatusBarMsg
.EnableCancelKey = xlErrorHandler
End With
End Sub
Sub SpeedOff()
With Application
.Calculation = glb_origCalculationMode
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.CalculateBeforeSave = True
.Cursor = xlDefault
.StatusBar = False
.EnableCancelKey = xlInterrupt
End With
End Sub
the referencing formulars you could add the 10 odd rows and clear their contents.
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks