代码拉取完成,页面将自动刷新
''''''''''''''''''''''''''''Concatenate worksheet by row''''''''''''''''''''''''''''
'Concatenate worksheets and save to new worksheet named VBAMerged
'Referenced function: GetRealRows(), WorksheetExists()
Sub MergeWorkSheets()
Dim srcWs As Worksheet
Dim dstWs As Worksheet
Dim srcUsedRowsCount As Integer
Dim dstUsedRowsCount As Integer
'create worksheet named VBAMerged, delete it and recreate if exist
If WorksheetExists("VBAMerged") Then
Application.DisplayAlerts = False
ThisWorkbook.Sheets("VBAMerged").Delete
Application.DisplayAlerts = True
End If
Set dstWs = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
dstWs.Name = "VBAMerged"
'Enumerate worksheets and copy all rows to VBAMerged
For Each srcWs In Worksheets
If Not srcWs.Name = "VBAMerged" Then
srcUsedRowCount = GetRealRows(srcWs)
dstUsedRowCount = dstWs.UsedRange.Rows.Count
'Copy with only value(not contains format)
'dstWs.Range(dstUsedRowCount + 1 & ":" & dstUsedRowCount + srcUsedRowCount).Value = srcWs.Range(1 & ":" & srcUsedRowCount).Value
'Copy for sourceTheme(contains format)
srcWs.Range(1 & ":" & srcUsedRowCount).Copy
If dstUsedRowCount = 1 Then
dstWs.Range(1 & ":" & srcUsedRowCount).PasteSpecial(xlPasteAllUsingSourceTheme)
Else
dstWs.Range(dstUsedRowCount + 1 & ":" & dstUsedRowCount + srcUsedRowCount).PasteSpecial(xlPasteAllUsingSourceTheme)
End If
End If
Next srcWs
End Sub
'Evaluate real used rows count
'By detecting empty rows not larger than maxEmptyRowsCount
Public Function GetRealRows(ByVal ws As Worksheet) As Integer
Dim emptyRowsCount As Integer
Dim usedRowsCount As Integer
Dim maxEmptyRowsCount As Integer
emptyRowsCount = 0
usedRowsCount = 0
maxEmptyRowsCount = 100
For Each Row In ws.Rows
usedRowsCount = usedRowsCount + 1
v = Row.Value
If Application.WorksheetFunction.CountA(ws.Range(usedRowsCount & ":" & usedRowsCount)) = 0 Then
emptyRowsCount = emptyRowsCount + 1
Else
emptyRowsCount = 0
End If
If emptyRowsCount >= maxEmptyRowsCount Then
Exit For
End If
Next Row
If usedRowsCount = 0 Then
GetRealRows = 1
Else
GetRealRows = usedRowsCount - emptyRowsCount
End If
End Function
'Detect whether the worksheet exists by the specified name
Public Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
WorksheetExists = Not sht Is Nothing
End Function
''''''''''''''''''''''''''''Fill color''''''''''''''''''''''''''''
'Parse r, g, b color split by comma and fill background
Sub FillAsRGB()
Dim lRow As Long
Dim lCol As Long
Dim cell As Range
lRow = Cells(Rows.Count, 1).End(xlUp).Row
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
Set rng = Range(Cells(1, 1), Cells(lRow, lCol))
For Each cell In rng
textArr = Split(cell.Value2, ",")
cell.Interior.Color = RGB(CInt(textArr(0)), CInt(textArr(1)), CInt(textArr(2)))
Next cell
Rng.ClearContents
End Sub
'Parse 24bit RGB color by color inedx(r* 256 * 256 + g * 256 + b)(from 0 to 255)and fill background
Sub FillAsRGB()
Dim lRow As Long
Dim lCol As Long
Dim cell As Range
lRow = Cells(Rows.Count, 1).End(xlUp).Row
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
Set Rng = Range(Cells(1, 1), Cells(lRow, lCol))
For Each cell In Rng
colorIdx = CLng(cell.Value2)
r = Fix(colorIdx / 256 / 256)
g = Fix((colorIdx - r * 256 * 256) / 256)
b = colorIdx - r * 256 * 256 - g * 256
cell.Interior.Color = RGB(r, g, b)
Next cell
Rng.ClearContents
End Sub
此处可能存在不合适展示的内容,页面不予展示。您可通过相关编辑功能自查并修改。
如您确认内容无涉及 不当用语 / 纯广告导流 / 暴力 / 低俗色情 / 侵权 / 盗版 / 虚假 / 无价值内容或违法国家有关法律法规的内容,可点击提交进行申诉,我们将尽快为您处理。