英文:
shorten if statement code adding last days of month as offset column
问题
以下是代码的中文翻译:
子过程 POS()
Dim shtDC As Worksheet: 设置 shtDC = 工作表("DC")
Dim pname As String, targetsht As String
Dim lrwsht As Long, i As Long, j As Long
Dim targetDate As Date
Dim searchRange As Range, cell As Range, cellc As Range
Dim lastDOM As Integer, sdate, addpm, cy
Dim lastJan, lastFeb, lastMar, lastApr, lastMay, lastJun
Dim lastJul, lastAug, lastSep, lastOct, lastNov
targetsht = shtDC.Range("A2")
cy = "2023" '根据需要更改年份
'清除名称
shtDC.Range("B7:H7,B9:H9,B11:H11,B13:H13,B15:H15,B17:H17").ClearContents
'设置目标日期值 - 要循环的月份
If Left(shtDC.Range("B4"), 3) = "Jan" Then
targetDate = DateValue(cy & "-01-01")
addpm = 0
ElseIf Left(shtDC.Range("B4"), 3) = "Feb" Then
targetDate = DateValue(cy & "-02-01")
ElseIf Left(shtDC.Range("B4"), 3) = "Mar" Then
targetDate = DateValue(cy & "-03-01")
ElseIf Left(shtDC.Range("B4"), 3) = "Apr" Then
targetDate = DateValue(cy & "-04-01")
ElseIf Left(shtDC.Range("B4"), 3) = "May" Then
targetDate = DateValue(cy & "-05-01")
ElseIf Left(shtDC.Range("B4"), 3) = "Jun" Then
targetDate = DateValue(cy & "-06-01")
ElseIf Left(shtDC.Range("B4"), 3) = "Jul" Then
targetDate = DateValue(cy & "-07-01")
ElseIf Left(shtDC.Range("B4"), 3) = "Aug" Then
targetDate = DateValue(cy & "-08-01")
ElseIf Left(shtDC.Range("B4"), 3) = "Sep" Then
targetDate = DateValue(cy & "-09-01")
ElseIf Left(shtDC.Range("B4"), 3) = "Oct" Then
targetDate = DateValue(cy & "-10-01")
ElseIf Left(shtDC.Range("B4"), 3) = "Nov" Then
targetDate = DateValue(cy & "-11-01")
ElseIf Left(shtDC.Range("B4"), 3) = "Dec" Then
targetDate = DateValue(cy & "-12-01")
End If
'设置附加偏移列 - 二月到十二月
If Left(shtDC.Range("B4"), 3) = "Feb" Then
lastJan = Day(Application.EoMonth(DateValue(cy & "-01-01"), 0))
addpm = lastJan
ElseIf Left(shtDC.Range("B4"), 3) = "Mar" Then
lastJan = Day(Application.EoMonth(DateValue(cy & "-01-01"), 0))
lastFeb = Day(Application.EoMonth(DateValue(cy & "-02-01"), 0))
addpm = lastJan + lastFeb
ElseIf Left(shtDC.Range("B4"), 3) = "Apr" Then
lastJan = Day(Application.EoMonth(DateValue(cy & "-01-01"), 0))
lastFeb = Day(Application.EoMonth(DateValue(cy & "-02-01"), 0))
lastMar = Day(Application.EoMonth(DateValue(cy & "-03-01"), 0))
addpm = lastJan + lastFeb + lastMar
'省略了其他月份的设置,你可以继续翻译它们
'...
'查找目标日期
Set searchRange = 工作表(targetsht).Range("F4:NF4")
For Each cell In searchRange
If DateValue(cell) = targetDate Then
lrwsht = 工作表(targetsht).Cells(Rows.Count, "C").End(xlUp).Row - 4
lastDOM = Day(Application.EoMonth(cell, 0)) - 1
'循环每个月的天数
For i = 0 To lastDOM
sdate = cell.Offset(0, i) '在DC工作表中搜索的日期
pname = ""
'循环名称
For j = 3 To lrwsht
If cell.Offset(j, i) = 1 Then
pname = pname & "-" & cell.Offset(j, -3 + (addpm * -1))
End If
Next j
'将名称复制到DC工作表
If pname <> "" Then
Set searchRange = shtDC.Range("B6:H16")
For Each cellc In searchRange
If cellc = sdate Then
cellc.Offset(1, 0) = Mid(pname, 2)
End If
Next cellc
End If
Next i
End If
Next cell
End Sub
希望这个翻译对你有所帮助。如果有任何问题,请随时提出。
英文:
just wondering if anybody has an idea to shorten the two if statement in the middle of the code, what the code does is find the sheet named in (A2 of sheet DC) then get the month of (B4 of sheet DC) then find the starting date of the month in sheet named in (A2 of sheet DC) which is targetsht Range("F4:NF4"),then using the offset line find a value of 1 then if true copy name in same row column C of targetsht, the addpm variable is an additional offset column since the dates are sequential Jan 1 to Dec 31 Range("F4:NF4")
Sub POS()
Dim shtDC As Worksheet: Set shtDC = Worksheets("DC")
Dim pname As String, targetsht As String
Dim lrwsht As Long, i As Long, j As Long
Dim targetDate As Date
Dim searchRange As Range, cell As Range, cellc As Range
Dim lastDOM As Integer, sdate, addpm, cy
Dim lastJan, lastFeb, lastMar, lastApr, lastMay, lastJun
Dim lastJul, lastAug, lastSep, lastOct, lastNov
targetsht = shtDC.Range("A2")
cy = "2023" 'change year accordingly
'clear names
shtDC.Range("B7:H7,B9:H9,B11:H11,B13:H13,B15:H15,B17:H17").ClearContents
'Set targetDate value - the month to loop
If Left(shtDC.Range("B4"), 3) = "Jan" Then
targetDate = DateValue(cy & "-01-01")
addpm = 0
ElseIf Left(shtDC.Range("B4"), 3) = "Feb" Then
targetDate = DateValue(cy & "-02-01")
ElseIf Left(shtDC.Range("B4"), 3) = "Mar" Then
targetDate = DateValue(cy & "-03-01")
ElseIf Left(shtDC.Range("B4"), 3) = "Apr" Then
targetDate = DateValue(cy & "-04-01")
ElseIf Left(shtDC.Range("B4"), 3) = "May" Then
targetDate = DateValue(cy & "-05-01")
ElseIf Left(shtDC.Range("B4"), 3) = "Jun" Then
targetDate = DateValue(cy & "-06-01")
ElseIf Left(shtDC.Range("B4"), 3) = "Jul" Then
targetDate = DateValue(cy & "-07-01")
ElseIf Left(shtDC.Range("B4"), 3) = "Aug" Then
targetDate = DateValue(cy & "-08-01")
ElseIf Left(shtDC.Range("B4"), 3) = "Sep" Then
targetDate = DateValue(cy & "-09-01")
ElseIf Left(shtDC.Range("B4"), 3) = "Oct" Then
targetDate = DateValue(cy & "-10-01")
ElseIf Left(shtDC.Range("B4"), 3) = "Nov" Then
targetDate = DateValue(cy & "-11-01")
ElseIf Left(shtDC.Range("B4"), 3) = "Dec" Then
targetDate = DateValue(cy & "-12-01")
End If
'set additional offset column - Feb to Dec
If Left(shtDC.Range("B4"), 3) = "Feb" Then
lastJan = Day(Application.EoMonth(DateValue(cy & "-01-01"), 0))
addpm = lastJan
ElseIf Left(shtDC.Range("B4"), 3) = "Mar" Then
lastJan = Day(Application.EoMonth(DateValue(cy & "-01-01"), 0))
lastFeb = Day(Application.EoMonth(DateValue(cy & "-02-01"), 0))
addpm = lastJan + lastFeb
ElseIf Left(shtDC.Range("B4"), 3) = "Apr" Then
lastJan = Day(Application.EoMonth(DateValue(cy & "-01-01"), 0))
lastFeb = Day(Application.EoMonth(DateValue(cy & "-02-01"), 0))
lastMar = Day(Application.EoMonth(DateValue(cy & "-03-01"), 0))
addpm = lastJan + lastFeb + lastMar
ElseIf Left(shtDC.Range("B4"), 3) = "May" Then
lastJan = Day(Application.EoMonth(DateValue(cy & "-01-01"), 0))
lastFeb = Day(Application.EoMonth(DateValue(cy & "-02-01"), 0))
lastMar = Day(Application.EoMonth(DateValue(cy & "-03-01"), 0))
lastApr = Day(Application.EoMonth(DateValue(cy & "-04-01"), 0))
addpm = lastJan + lastFeb + lastMar + lastApr
ElseIf Left(shtDC.Range("B4"), 3) = "Jun" Then
lastJan = Day(Application.EoMonth(DateValue(cy & "-01-01"), 0))
lastFeb = Day(Application.EoMonth(DateValue(cy & "-02-01"), 0))
lastMar = Day(Application.EoMonth(DateValue(cy & "-03-01"), 0))
lastApr = Day(Application.EoMonth(DateValue(cy & "-04-01"), 0))
lastMay = Day(Application.EoMonth(DateValue(cy & "-05-01"), 0))
addpm = lastJan + lastFeb + lastMar + lastApr + lastMay
ElseIf Left(shtDC.Range("B4"), 3) = "Jul" Then
lastJan = Day(Application.EoMonth(DateValue(cy & "-01-01"), 0))
lastFeb = Day(Application.EoMonth(DateValue(cy & "-02-01"), 0))
lastMar = Day(Application.EoMonth(DateValue(cy & "-03-01"), 0))
lastApr = Day(Application.EoMonth(DateValue(cy & "-04-01"), 0))
lastMay = Day(Application.EoMonth(DateValue(cy & "-05-01"), 0))
lastJun = Day(Application.EoMonth(DateValue(cy & "-06-01"), 0))
addpm = lastJan + lastFeb + lastMar + lastApr + lastMay + lastJun
ElseIf Left(shtDC.Range("B4"), 3) = "Aug" Then
lastJan = Day(Application.EoMonth(DateValue(cy & "-01-01"), 0))
lastFeb = Day(Application.EoMonth(DateValue(cy & "-02-01"), 0))
lastMar = Day(Application.EoMonth(DateValue(cy & "-03-01"), 0))
lastApr = Day(Application.EoMonth(DateValue(cy & "-04-01"), 0))
lastMay = Day(Application.EoMonth(DateValue(cy & "-05-01"), 0))
lastJun = Day(Application.EoMonth(DateValue(cy & "-06-01"), 0))
lastJul = Day(Application.EoMonth(DateValue(cy & "-07-01"), 0))
addpm = lastJan + lastFeb + lastMar + lastApr + lastMay + lastJun + lastJul
ElseIf Left(shtDC.Range("B4"), 3) = "Sep" Then
lastJan = Day(Application.EoMonth(DateValue(cy & "-01-01"), 0))
lastFeb = Day(Application.EoMonth(DateValue(cy & "-02-01"), 0))
lastMar = Day(Application.EoMonth(DateValue(cy & "-03-01"), 0))
lastApr = Day(Application.EoMonth(DateValue(cy & "-04-01"), 0))
lastMay = Day(Application.EoMonth(DateValue(cy & "-05-01"), 0))
lastJun = Day(Application.EoMonth(DateValue(cy & "-06-01"), 0))
lastJul = Day(Application.EoMonth(DateValue(cy & "-07-01"), 0))
lastAug = Day(Application.EoMonth(DateValue(cy & "-08-01"), 0))
addpm = lastJan + lastFeb + lastMar + lastApr + lastMay + lastJun + lastJul + lastAug
ElseIf Left(shtDC.Range("B4"), 3) = "Oct" Then
lastJan = Day(Application.EoMonth(DateValue(cy & "-01-01"), 0))
lastFeb = Day(Application.EoMonth(DateValue(cy & "-02-01"), 0))
lastMar = Day(Application.EoMonth(DateValue(cy & "-03-01"), 0))
lastApr = Day(Application.EoMonth(DateValue(cy & "-04-01"), 0))
lastMay = Day(Application.EoMonth(DateValue(cy & "-05-01"), 0))
lastJun = Day(Application.EoMonth(DateValue(cy & "-06-01"), 0))
lastJul = Day(Application.EoMonth(DateValue(cy & "-07-01"), 0))
lastAug = Day(Application.EoMonth(DateValue(cy & "-08-01"), 0))
lastSep = Day(Application.EoMonth(DateValue(cy & "-09-01"), 0))
addpm = lastJan + lastFeb + lastMar + lastApr + lastMay + lastJun + lastJul + lastAug + lastSep
ElseIf Left(shtDC.Range("B4"), 3) = "Nov" Then
lastJan = Day(Application.EoMonth(DateValue(cy & "-01-01"), 0))
lastFeb = Day(Application.EoMonth(DateValue(cy & "-02-01"), 0))
lastMar = Day(Application.EoMonth(DateValue(cy & "-03-01"), 0))
lastApr = Day(Application.EoMonth(DateValue(cy & "-04-01"), 0))
lastMay = Day(Application.EoMonth(DateValue(cy & "-05-01"), 0))
lastJun = Day(Application.EoMonth(DateValue(cy & "-06-01"), 0))
lastJul = Day(Application.EoMonth(DateValue(cy & "-07-01"), 0))
lastAug = Day(Application.EoMonth(DateValue(cy & "-08-01"), 0))
lastSep = Day(Application.EoMonth(DateValue(cy & "-09-01"), 0))
lastOct = Day(Application.EoMonth(DateValue(cy & "-10-01"), 0))
addpm = lastJan + lastFeb + lastMar + lastApr + lastMay + lastJun + lastJul + lastAug + lastSep + lastOct
ElseIf Left(shtDC.Range("B4"), 3) = "Dec" Then
lastJan = Day(Application.EoMonth(DateValue(cy & "-01-01"), 0))
lastFeb = Day(Application.EoMonth(DateValue(cy & "-02-01"), 0))
lastMar = Day(Application.EoMonth(DateValue(cy & "-03-01"), 0))
lastApr = Day(Application.EoMonth(DateValue(cy & "-04-01"), 0))
lastMay = Day(Application.EoMonth(DateValue(cy & "-05-01"), 0))
lastJun = Day(Application.EoMonth(DateValue(cy & "-06-01"), 0))
lastJul = Day(Application.EoMonth(DateValue(cy & "-07-01"), 0))
lastAug = Day(Application.EoMonth(DateValue(cy & "-08-01"), 0))
lastSep = Day(Application.EoMonth(DateValue(cy & "-09-01"), 0))
lastOct = Day(Application.EoMonth(DateValue(cy & "-10-01"), 0))
lastNov = Day(Application.EoMonth(DateValue(cy & "-11-01"), 0))
addpm = lastJan + lastFeb + lastMar + lastApr + lastMay + lastJun + lastJul + lastAug + lastSep + lastOct + lastNov
End If
'Find targetDate
Set searchRange = Worksheets(targetsht).Range("F4:NF4")
For Each cell In searchRange
If DateValue(cell) = targetDate Then
lrwsht = Worksheets(targetsht).Cells(Rows.Count, "C").End(xlUp).Row - 4
lastDOM = Day(Application.EoMonth(cell, 0)) - 1
'loop thru days of the month
For i = 0 To lastDOM
sdate = cell.Offset(0, i) 'date to search in dc sheet
pname = ""
'loop thru names
For j = 3 To lrwsht
If cell.Offset(j, i) = 1 Then
pname = pname & "-" & cell.Offset(j, -3 + (addpm * -1))
End If
Next j
'copy names to dc sheet
If pname <> "" Then
Set searchRange = shtDC.Range("B6:H16")
For Each cellc In searchRange
If cellc = sdate Then
cellc.Offset(1, 0) = Mid(pname, 2)
End If
Next cellc
End If
Next i
End If
Next cell
End Sub
答案1
得分: 3
以下是VBA代码的翻译部分:
Option Explicit
Sub POS()
Dim wb As Workbook, shtDC As Worksheet, shtTarget As Worksheet
Dim rng As Range, cel As Range, col As Range
Dim cy As Double, mth As String, n As Long
Dim dtStart As Date, dtEnd As Date, dt As Date, ar(1 To 31) As String
Dim lastrow As Long, r As Long, c As Long, d As Long
Set wb = ThisWorkbook
Set shtDC = wb.Sheets("DC")
With shtDC
'清除名称
.Range("B7:H7,B9:H9,B11:H11,B13:H13,B15:H15,B17:H17").ClearContents
Set shtTarget = wb.Sheets(.Range("A2").Value)
mth = Left(.Range("B4"), 3)
End With
'循环的月份
cy = Year(Date) '更改年份
dtStart = DateValue(cy & "-" & mth & "-01")
dtEnd = DateAdd("m", 1, dtStart) - 1
'查找开始日期
With shtTarget
Set col = .Range("F4").Offset(0, DateDiff("d", DateSerial(cy, 1, 1), dtStart))
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
d = 1
For dt = dtStart To dtEnd
If col <> dt Then
MsgBox "日期错误,位置:" & col.Address & " 不是 " & dt, vbCritical
Exit Sub
End If
'扫描并将名称添加到数组
c = col.Column
For r = 3 To lastrow - 4
If .Cells(r, c) = 1 Then
ar(d) = ar(d) & "-" & .Cells(r, "C")
End If
Next
d = d + 1
Set col = col.Offset(, 1)
Next
End With
'更新DC表
With Sheets("DC")
Set rng = .Range("B6:H16")
For d = 1 To 31
If ar(d) <> "" Then
dt = dtStart + d - 1
Set cel = rng.Find(Format(dt, "d-mmm-yy"), LookIn:=xlValues, lookat:=xlWhole)
If cel Is Nothing Then
MsgBox Format(dt, "d-mmm-yy") & _
" 未在 " & rng.Address & " 找到", vbExclamation
Else
cel.Offset(1) = Mid(ar(d), 2) ' 去除 "-"
n = n + 1
End If
End If
Next
End With
MsgBox n & " 天已更新" & vbLf & dtStart & " - " & dtEnd, vbInformation
End Sub
英文:
Option Explicit
Sub POS()
Dim wb As Workbook, shtDC As Worksheet, shtTarget As Worksheet
Dim rng As Range, cel As Range, col As Range
Dim cy As Double, mth As String, n As Long
Dim dtStart As Date, dtEnd As Date, dt As Date, ar(1 To 31) As String
Dim lastrow As Long, r As Long, c As Long, d As Long
Set wb = ThisWorkbook
Set shtDC = wb.Sheets("DC")
With shtDC
'clear names
.Range("B7:H7,B9:H9,B11:H11,B13:H13,B15:H15,B17:H17").ClearContents
Set shtTarget = wb.Sheets(.Range("A2").Value)
mth = Left(.Range("B4"), 3)
End With
'the month to loop
cy = Year(Date) '"2023" 'change year accordingly
dtStart = DateValue(cy & "-" & mth & "-01")
dtEnd = DateAdd("m", 1, dtStart) - 1
'Find StartDate
With shtTarget
Set col = .Range("F4").Offset(0, DateDiff("d", DateSerial(cy, 1, 1), dtStart))
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
d = 1
For dt = dtStart To dtEnd
If col <> dt Then
MsgBox "Date error at " & col.Address & " not " & dt, vbCritical
Exit Sub
End If
' scan down adding names to array
c = col.Column
For r = 3 To lastrow - 4
If .Cells(r, c) = 1 Then
ar(d) = ar(d) & "-" & .Cells(r, "C")
End If
Next
d = d + 1
Set col = col.Offset(, 1)
Next
End With
'update DC sheet
With Sheets("DC")
Set rng = .Range("B6:H16")
For d = 1 To 31
If ar(d) <> "" Then
dt = dtStart + d - 1
Set cel = rng.Find(Format(dt, "d-mmm-yy"), LookIn:=xlValues, lookat:=xlWhole)
If cel Is Nothing Then
MsgBox Format(dt, "d-mmm-yy") & _
" not found in " & rng.Address, vbExclamation
Else
cel.Offset(1) = Mid(ar(d), 2) ' remove -
n = n + 1
End If
End If
Next
End With
MsgBox n & " days updated" & vbLf & dtStart _
& " - " & dtEnd, vbInformation
End Sub
</details>
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库,让每个人都能够通过互相帮助和分享经验来进步。
评论