Created
January 14, 2019 09:55
-
-
Save Miniwe/5dd5a9bb3982ba199c891a0135fcc917 to your computer and use it in GitHub Desktop.
копирование выделенных ячеек в отдельный лист
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Sub SelectActualUsedRange() | |
Dim FirstCell As Range, LastCell As Range | |
Set LastCell = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, _ | |
SearchDirection:=xlPrevious, LookIn:=xlValues).row, _ | |
Cells.Find(What:="*", SearchOrder:=xlByColumns, _ | |
SearchDirection:=xlPrevious, LookIn:=xlValues).Column) | |
Set FirstCell = Cells(Cells.Find(What:="*", After:=LastCell, SearchOrder:=xlRows, _ | |
SearchDirection:=xlNext, LookIn:=xlValues).row, _ | |
Cells.Find(What:="*", After:=LastCell, SearchOrder:=xlByColumns, _ | |
SearchDirection:=xlNext, LookIn:=xlValues).Column) | |
Range(FirstCell, LastCell).Select | |
End Sub | |
Sub SelectColoredCells(sheet As Worksheet, color As String) | |
Dim rCell As Range | |
Dim lColor As Long | |
Dim rColored As Range | |
Dim mySel As Range | |
Dim col As Integer | |
Dim row As Integer | |
col = 1 | |
row = 1 | |
'Select the color by name (8 possible) | |
'vbBlack, vbBlue, vbGreen, vbCyan, | |
'vbRed, vbMagenta, vbYellow, vbWhite | |
lColor = color | |
'If you prefer, you can use the RGB function | |
'to specify a color | |
'lColor = RGB(0, 0, 255) | |
Sheets("sh1").Activate | |
Call SelectActualUsedRange | |
Set rColored = Nothing | |
For Each rCell In Selection | |
If rCell.Interior.color = lColor Then | |
If rColored Is Nothing Then | |
Set rColored = rCell | |
Else | |
Set rColored = Union(rColored, rCell) | |
End If | |
rCell.Copy sheet.Range(Cells(row, col).Address) | |
col = col + 1 | |
If col Mod 4 = 0 Then | |
row = row + 1 | |
col = 1 | |
End If | |
End If | |
Next | |
If rColored Is Nothing Then | |
MsgBox "No cells match the color" | |
Else | |
rColored.Select | |
MsgBox "Selected cells match the color:" & _ | |
vbCrLf & rColored.Address | |
End If | |
Set rCell = Nothing | |
Set rColored = Nothing | |
sheet.Activate | |
End Sub | |
Sub Printsheet() | |
Dim wsA As Worksheet | |
Dim newWs As Worksheet | |
Dim mainWB As Workbook | |
Set mainWB = ActiveWorkbook | |
Set wsA = Sheets("sh1") | |
Dim Newname As String | |
Newname = "selected" | |
Sheets.Add _ | |
After:=mainWB.Sheets(mainWB.Sheets.Count), _ | |
Type:=xlWorksheet | |
ActiveSheet.Name = Newname & mainWB.Sheets.Count | |
Set newWs = ActiveSheet | |
Dim color As String | |
color = wsA.Range("A1").Interior.color | |
wsA.Activate | |
' color 16777215 = no color | |
If Not color = 16777215 Then | |
MsgBox "Has Color " & color | |
Call SelectColoredCells(newWs, color) | |
Else | |
MsgBox "A1 no colored" | |
End If | |
End Sub | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment