سلام دوستان من میخوام دو ماکرو ادغام بشه و با یک بار اجرا هر دو ماکرو اعمال بشه؟
این کدها هستش:
Sub RemoveHiddenRows()
Dim xRow As Range
Dim xRg As Range
Dim xRows As Range
On Error Resume Next
Set xRows = Intersect(ActiveSheet.Range("A:A").EntireRow, ActiveSheet.UsedRange)
If xRows Is Nothing Then Exit Sub
For Each xRow In xRows.Columns(1).Cells
If xRow.EntireRow.Hidden Then
If xRg Is Nothing Then
Set xRg = xRow
Else
Set xRg = Union(xRg, xRow)
End If
End If
Next
If Not xRg Is Nothing Then
xRg.EntireRow.Delete
End If
End Sub
و کد دوم:
Sub CreateWorkbooks()
Dim wb As Workbook
Dim wbs As Workbook
Dim sht As Object
Dim strSavePath As String
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
strSavePath = "C:\Users\alacik\Desktop"
Set wbs = ActiveWorkbook
For Each sht In wbs.Sheets
sht.Copy
Set wb = ActiveWorkbook
wb.SaveAs strSavePath & sht.Name
wb.Close
Next
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox "Failed. Error number=" & Err.Number & ". Error description=" & Err.Description & "."
End Sub
این کدها هستش:
Sub RemoveHiddenRows()
Dim xRow As Range
Dim xRg As Range
Dim xRows As Range
On Error Resume Next
Set xRows = Intersect(ActiveSheet.Range("A:A").EntireRow, ActiveSheet.UsedRange)
If xRows Is Nothing Then Exit Sub
For Each xRow In xRows.Columns(1).Cells
If xRow.EntireRow.Hidden Then
If xRg Is Nothing Then
Set xRg = xRow
Else
Set xRg = Union(xRg, xRow)
End If
End If
Next
If Not xRg Is Nothing Then
xRg.EntireRow.Delete
End If
End Sub
و کد دوم:
Sub CreateWorkbooks()
Dim wb As Workbook
Dim wbs As Workbook
Dim sht As Object
Dim strSavePath As String
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
strSavePath = "C:\Users\alacik\Desktop"
Set wbs = ActiveWorkbook
For Each sht In wbs.Sheets
sht.Copy
Set wb = ActiveWorkbook
wb.SaveAs strSavePath & sht.Name
wb.Close
Next
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox "Failed. Error number=" & Err.Number & ". Error description=" & Err.Description & "."
End Sub
کامنت