排序而不移动格式 [英] Sort without moving formatting
本文介绍了排序而不移动格式的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我可以以另一种方式格式化停止这样会使单元格保持锁定？
我用于格式化的代码是：
对于每行在rng.Rows
如果条件然后
Row.Select
cIndex = ColourIndex （颜色）
与Selection.Interior
.ColorIndex = cIndex
结束
结束如果
下一个
我的表的一个例子是这样的：
编辑：额外的代码
Sub Quota（ByVal Type As String）
Dim records As Long
Dim sht1 As Worksheet
Set sht1 = Worksheets（Sheet1）
Dim sht2 As Worksheet
设置sht2 =工作表（Sheet2）
records = sht1.Range（A 1048576）。End（xlUp）.Row - 5
Dim rng As Range
Dim rngRowCount As Long
Dim rLastCell As Range
Dim i As Long
sht2.Activate
'最后使用的单元格
设置rLastCell = sht2.Cells.Find（什么：=*，之后：=单元格（1，1） ，LookIn：= xlFormulas，LookAt：= _
xlPart，SearchOrder：= xlByRows，SearchDirection：= xlPrevious，MatchCase：= False）
'除了1st
之外的所有使用的列设置rng = sht2。范围（单元格（2，1），rLastCell）
rng.Select
rngRowCount = rng.Rows.CountLarge
对于i = 1 To rngRowCount
Dim valueAs String
Dim color As String
Dim VarX As Long
Dim maxValue As Long
value = sht2.Cells（i + 1，1）.Value
color = sht2.Cells（i + 1，2）.Value
如果Type =A则
VarX = sht2.Cells（i + 1，3）。值
ElseIf Type =B然后
VarX = sht2.Cells（i + 1，5）.Value
End If
maxValue =（records / 100 ）* VarX
ColourRows值，颜色，maxValue
下一页
End Sub
Sub ColourRows（value As String，color As String，maxValue As Long）
Dim sht1 As Worksheet
Set sht1 =工作表（Sheet1）
sht1.Activate
Dim rng As Range
Dim firstSixRowsOnwards As Range
Dim lastColumn As Long
Dim usedColumns As范围
Dim usedColumnsString As String
Dim highlightColumns As Range
Dim rngDataRowCount As Long
Dim performancevalueAs String
Dim cIndex As Integer
Dim count As Long
count = 0
Dim rLastCell As Range
'结束行
rngDataRowCount = sht1.Range（A1048576）。End（xlUp ）.Row
'前6行
设置firstSixRowsOnwards = sht1.Range（A6：XFD1048576）
'最后一列
lastColumn = Cells.Find（*，SearchOrder ：= xlByColumns，SearchDirection：= xlPrevious）.Column
'Used range
设置rng = sht1.Range（Cells（1，1），Cells（rngDataRowCount，lastColumn））
'Used Columns
设置usedColumns = sht1.Range（Cells（1，1），Ce lls（1048576，lastColumn））
设置rng =相交（rng，firstSixRowsOnwards，usedColumns）
对于每行在rng.Rows
compareValue =单元格（Row.Row，5））值
If（InStr（1，value，compareValue，1）Then
Dim rowNumber As Long
Row 。选择
如果count< maxValue然后
cIndex = ColourIndex（color）
With Selection.Interior
.ColorIndex = cIndex
结束
count = count + 1
Else
cIndex = 3'red
With Selection.Interior
.ColorIndex = cIndex
结束
结束如果
结束如果
下一个
结束Sub
解决方案
可以用CF完成，例如（最高规则是> 11）：
编辑 - 我无意中遗漏了一个规则
下面的第二个使用 = ROW（$ A1）= 11 ：
I have an Excel table in which multiple rows are given different coloured backgrounds by VBA macros. These background colours should be locked to the rows. My problem is that when the table is sorted by one column or another the background colours move as the data is reordered.
Can I format in another way to stop this happening so that the cells remain locked?
The code I use to format is:
For Each Row In rng.Rows
If Condition Then
Row.Select
cIndex = ColourIndex(colour)
With Selection.Interior
.ColorIndex = cIndex
End With
End If
Next
An example of my table is like this:
EDIT: Extra Code
Sub Quota(ByVal Type As String)
Dim records As Long
Dim sht1 As Worksheet
Set sht1 = Worksheets("Sheet1")
Dim sht2 As Worksheet
Set sht2 = Worksheets("Sheet2")
records = sht1.Range("A1048576").End(xlUp).Row - 5
Dim rng As Range
Dim rngRowCount As Long
Dim rLastCell As Range
Dim i As Long
sht2.Activate
'Last used cell
Set rLastCell = sht2.Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
'All used columns except 1st
Set rng = sht2.Range(Cells(2, 1), rLastCell)
rng.Select
rngRowCount = rng.Rows.CountLarge
For i = 1 To rngRowCount
Dim valueAs String
Dim colour As String
Dim VarX As Long
Dim maxValue As Long
value= sht2.Cells(i + 1, 1).Value
colour = sht2.Cells(i + 1, 2).Value
If Type = "A" Then
VarX = sht2.Cells(i + 1, 3).Value
ElseIf Type = "B" Then
VarX = sht2.Cells(i + 1, 5).Value
End If
maxValue = (records / 100) * VarX
ColourRows value, colour, maxValue
Next i
End Sub
Sub ColourRows(value As String, colour As String, maxValue As Long)
Dim sht1 As Worksheet
Set sht1 = Worksheets("Sheet1")
sht1.Activate
Dim rng As Range
Dim firstSixRowsOnwards As Range
Dim lastColumn As Long
Dim usedColumns As Range
Dim usedColumnsString As String
Dim highlightedColumns As Range
Dim rngDataRowCount As Long
Dim performancevalueAs String
Dim cIndex As Integer
Dim count As Long
count = 0
Dim rLastCell As Range
'End row
rngDataRowCount = sht1.Range("A1048576").End(xlUp).Row
'First 6 rows
Set firstSixRowsOnwards = sht1.Range("A6:XFD1048576")
'Last column
lastColumn = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
'Used Range
Set rng = sht1.Range(Cells(1, 1), Cells(rngDataRowCount, lastColumn))
'Used Columns
Set usedColumns = sht1.Range(Cells(1, 1), Cells(1048576, lastColumn))
Set rng = Intersect(rng, firstSixRowsOnwards, usedColumns)
For Each Row In rng.Rows
compareValue= Cells(Row.Row, 5)).Value
If (InStr(1, value, compareValue, 1) Then
Dim rowNumber As Long
Row.Select
If count < maxValue Then
cIndex = ColourIndex(colour)
With Selection.Interior
.ColorIndex = cIndex
End With
count = count + 1
Else
cIndex = 3 'red
With Selection.Interior
.ColorIndex = cIndex
End With
End If
End If
Next
End Sub
解决方案
Can be done with CF, for example (top rule is >11):
Edit - I inadvertently left out one rule
the second down below uses =ROW($A1)=11:
这篇关于排序而不移动格式的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
