1 Star 1 Fork 1

kylindebug / ExcelVBA

加入 Gitee
与超过 1200万 开发者一起发现、参与优秀开源项目,私有仓库也完全免费 :)
免费加入
该仓库未声明开源许可证文件(LICENSE),使用请关注具体项目描述及其代码上游依赖。
克隆/下载
Code.vb 4.10 KB
一键复制 编辑 Web IDE 原始数据 按行查看 历史
kylindebug 提交于 2020-08-26 13:13 . update Code.vb.
''''''''''''''''''''''''''''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
Visual Basic
1
https://gitee.com/kylindebug/excel-vba.git
git@gitee.com:kylindebug/excel-vba.git
kylindebug
excel-vba
ExcelVBA
master

搜索帮助

14c37bed 8189591 565d56ea 8189591