我承認在 VBA 方面不是最好的。
我有一個 Excel 作業表，其中有一些代碼隱藏在按鈕后面，用于從網路位置進行匯入。
B 列的日期格式為 dd/mm/yyyy。
我的匯入洗掉了重復項并按時間順序重新排序，我還想添加一些可視化方法，根據周數將行劃分為周數。我正在考慮插入一行。
我應該如何測驗從第 45 周到第 46 周的周數變化，例如添加一行？
uj5u.com熱心網友回復：
按周分組資料
- 請注意，Week 列與代碼無關，只考慮 Date 列。
用法
Sub GroupWeekTEST()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
GroupByWeek ws, "B2", "A", "Week " ' you can omit the last two defaults
End Sub
方法
Sub GroupByWeek( _
ByVal ws As Worksheet, _
ByVal WeekFirstCellAddress As String, _
Optional ByVal GroupColumn As Variant = "A", _
Optional ByVal GroupBaseName As String = "Week ")
' Reference the single-column range ('crg').
Dim fCell As Range: Set fCell = ws.Range(WeekFirstCellAddress)
Dim lCell As Range
Set lCell = fCell.Resize(ws.Rows.Count - fCell.Row 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Sub ' no data in column range
Dim rCount As Long: rCount = lCell.Row - fCell.Row 1
Dim crg As Range: Set crg = fCell.Resize(rCount)
' Write the values from the range to an array ('Data').
Dim Data As Variant
If rCount = 1 Then
ReDim Data(1 To 1, 1 To 1): Data = crg.Value
Else
Data = crg.Value
End If
' The 1st column will hold the cells (range objects).
' Add a 2nd column to hold the week numbers.
ReDim Preserve Data(1 To rCount, 1 To 2)
' Write the cells and week numbers to the top of the array.
Dim CurrValue As Variant
Dim CurrDate As Date
Dim OldWeek As Long
Dim NewWeek As Long
Dim sr As Long
Dim dr As Long
For sr = 1 To rCount
CurrValue = Data(sr, 1)
If IsDate(CurrValue) Then
NewWeek = Application.WeekNum(CurrValue)
If NewWeek <> OldWeek Then
dr = dr 1
Set Data(dr, 1) = crg.Cells(sr)
Data(dr, 2) = NewWeek
OldWeek = NewWeek
End If
End If
Next sr
If dr = 0 Then Exit Sub ' no dates found
' Write the group titles to the specified column of the newly inserted rows.
Application.ScreenUpdating = False
For dr = dr To 1 Step -1
With Data(dr, 1)
.EntireRow.Insert xlShiftDown
.Offset(-1).EntireRow.Columns(GroupColumn).Value _
= GroupBaseName & Data(dr, 2)
End With
Next dr
Application.ScreenUpdating = True
' Inform.
MsgBox "Week grouping added.", vbInformation
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/533432.html
標籤：擅长vba