编辑2-由共产国际解决-此处缺少定义-
Rows(r.Row + counter & ":" & r.Row + counter).Insert Shift:=xlDown
应阅读
ws.Rows(r.Row + counter & ":" & r.Row + counter).Insert Shift:=xlDown
原始帖子- 我有一个要尝试使用的主要主要功能的工具-
它在我的计算机上运行良好，并且在逐步运行时在同事的计算机上运行良好。但是，在同事计算机上运行代码后，所有内容都可以运行，但输出却不同。 〜Edit 我在同事的PC上逐步运行远程操作，同时在自己的PC上逐步运行，以确认输出是否相同
我已经检查了一下，但无法找出导致此问题的原因。
代码是通过按钮运行的，因此不要认为这是Activesheet的问题。另外，我想我已经将每个范围/引用链接到一个命名工作表。另外，我没有遇到错误，只是给出了不同的输出（特别是，输出中删除了更多行）
Sub FDA_Macro_Clean()
Dim ws As Worksheet
Dim wb As Workbook, outputwb As Workbook
Dim lastrow As Integer, x As Integer, y As Integer
Dim rownum As Long, rownum2 As Long, string1 As Long, string2 As Long, counter As Long
Dim r As Range
Dim timeslot As String, shareddrive As String, savename As String
Application.DisplayAlerts = False 'turns off alerts
Application.ScreenUpdating = False 'turns off screen updates
'###################################### - Defines Workbook and Sheets
Set wb = Workbooks("FDA Macro Template - No GRID 11-28 2pm.xlsm")
Set ws = wb.Sheets("Import Declaration Report")
'###################################### - Delete unused cells
ws.Rows("1:56").Delete
ws.Range("A:B,Q:Q").Delete
'###################################### - defines final active row (1 of 3 times we define)
lastrow = ws.Range("a" & Rows.Count).End(xlUp).Row
'###################################### - Delete s cells which are out of scope
x = 2
Do Until x = lastrow + 1
If ws.Range("H" & x).Value = "APH - MAY PROCEED" Or ws.Range("H" & x).Value = "FDA - " Then
ws.Range("H" & x).EntireRow.Delete 'Deletes rows with above 2 criteria values
x = x - 1
End If
x = x + 1
Loop
'###################################### - Creates new rows for anything where column A/B has different values
rownum = 1
Do Until ws.Range("A" & rownum) = ""
string1 = UBound(Split(ws.Range("A" & rownum), ",")) 'counts instances of "," in Column A
string2 = UBound(Split(ws.Range("B" & rownum), ",")) 'counts instances of "," in Column B
If string1 <> string2 Or string1 = 0 Then 'if the strings are 0, skip to next item. If strings mismatch, follow error path
If string1 <> string2 Then 'If strings mismatch, follow error path
ws.Range("A" & rownum & ":N" & rownum).Interior.Color = RGB(236, 110, 212) 'ERROR PATH - Highlight Purple
ws.Range("M" & rownum).Value = ws.Range("M" & rownum).Value & "Bill/Container count mismatch" 'ERROR PATH - Add comment in column M
y = y + 1 'Value of Y is used to determine if there is an error later in the macro
End If
rownum = rownum + 1 'Next row
GoTo NextRowLoop 'increases RowNum by 1 and skips the split
End If
'Part 2 - only for lines where String1 <> 0 and String1 = String2
Set r = ws.Range("a" & rownum) 'sets r to current cell - CBL column
Dim arr As Variant
arr = Split(r, ", ") 'fills array with each bill, removing the ", "
r = arr(0) 'puts the first array value in Range 'A&r'
For counter = 1 To UBound(arr) 'adds a counter from 1 to UBound
Rows(r.Row + counter & ":" & r.Row + counter).Insert Shift:=xlDown 'inserts a new row
r.Offset(counter, 0) = arr(counter) 'puts each additional Array entry in a row added below (because location is tied to 'counter', the gap increases by one each loop)
Next counter
Erase arr 'clears the array
Set r = ws.Range("b" & rownum) 'sets range to current cell - Container column
arr = Split(r, ", ") 'fills array with each bill, removing the ", "
r = arr(0) 'puts the first array value in Range 'B&r'
For counter = 1 To UBound(arr)
r.Offset(counter, 0) = arr(counter) 'puts each additional Array entry in a row added below (because location is tied to 'counter', the gap increases by one each loop)
ws.Range(r.Offset(counter, 1), r.Offset(counter, 12)).Value = ws.Range(r.Offset(counter - 1, 1), r.Offset(counter, 12)).Value 'fills all other report data down for columns C-N
Next counter
Erase arr 'clears the array
rownum = rownum + counter 'adds the counter value to the rownum value, so we don't look in the new lines we created
NextRowLoop: 'bookmark which links to the String1 / String2 IF argument
Loop
'###################################### - redefine lastrow (2 of 3 times we define)
lastrow = ws.Range("a" & Rows.Count).End(xlUp).Row
'###################################### - Delete rows, or recolour rows based on PGA Status Description
x = 2
Do Until x = lastrow + 1
If ws.Range("H" & x).Interior.Color = RGB(236, 110, 212) Then 'FInds rows already PURPLE
GoTo NextRowLoop2 'if row colour is purple, skip
ElseIf ws.Range("H" & x).Value = "FDA - MAY PROCEED" Or ws.Range("H" & x).Value = "FDA - MAY PROCEED; APH - MAY PROCEED" Or ws.Range("H" & x).Value = "APH - MAY PROCEED; FDA - MAY PROCEED" Then
ws.Range("A" & x & ":N" & x).Interior.Color = RGB(129, 235, 111) 'sets rows with above criteria to GREEN
ElseIf Left(ws.Range("H" & x).Value, 20) = "FDA - DATA UNDER PGA" Then
ws.Range("A" & x & ":N" & x).Interior.Color = RGB(255, 255, 0) 'sets rows with above criteria to YELLOW
ElseIf ws.Range("H" & x).Value = "FDA - Hold Intact" Then
ws.Range("A" & x & ":N" & x).Interior.Color = RGB(255, 0, 0) 'sets rows with above criteria to RED
End If
NextRowLoop2:
x = x + 1
Loop
'###################################### - sorts based on colour Purple > Red > Yellow > Green
With ws.Sort
With .SortFields
.Clear
.Add(ws.Range("A2"), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(236, 110, 212)
.Add(ws.Range("A2"), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(129, 235, 111)
.Add(ws.Range("A2"), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, 255, 0)
.Add(ws.Range("A2"), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, 0, 0)
.Add Key:=ws.Range("C2"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
End With
.SetRange ws.Range("A1").CurrentRegion
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'###################################### - Reformatting for selected columns and autofits cells
ws.Range("C2:D" & lastrow, "I2:J" & lastrow).NumberFormat = "yyyy-mm-dd" 'sets date format in date cells
ws.Range("E2:F" & lastrow).NumberFormat = "General" 'sets general format for Entry Port and Entry Number
ws.Columns("A:N").AutoFit 'autofit columns
ws.Rows("1:" & lastrow).EntireRow.AutoFit 'autofit rows
'###################################### - Creates a new workbook and moves just the output sheet
Set outputwb = Workbooks.Add
ws.Copy Before:=outputwb.Sheets(1)
outputwb.Sheets("Sheet1").Delete
'###################################### - Error Path - cleans the Macro workbook and promts user to fix Purple rows. Exit sub without saving file (needs manual saving)
If y > 0 Then
Application.DisplayAlerts = True 'turns on alerts
Application.ScreenUpdating = True 'turns on screen updates
ws.Cells.ClearContents
ws.Cells.Interior.Color = xlNone
MsgBox "Workbook has " & y & " lines where Number of Bills in Column A does not match Number of Containers in Column B. " & vbNewLine & vbNewLine & "Rows still requiring rework are highlighted Purple, and comment added to Column M." _
& vbNewLine & vbNewLine & "All other rows have been processed" & vbNewLine & vbNewLine & "Macro will now exit. Once reworked, please manually save."
Exit Sub
End If
'###################################### - Zero Error Path - cleans the Macro workbook
ws.Cells.ClearContents
ws.Cells.Interior.Color = xlNone
'###################################### - 'Saves file based on the Time we're running it
If Time() < TimeValue("13:29:00") Then
timeslot = "(Morning)"
ElseIf Time() < TimeValue("16:19:00") Then
timeslot = "(Midday)"
Else: timeslot = "(Afternoon)"
End If
shareddrive = "X:\HD Folders\HD-FDA REPORTS\DAILY FDA SHIPMENT REPORT\"
savename = "DAILY FDA SHIPMENT REPORT " & Format(Now(), ("mm.dd.yy")) & " " & timeslot
outputwb.SaveAs shareddrive & savename & ".xlsx"
Application.DisplayAlerts = True 'turns on alerts
Application.ScreenUpdating = True 'turns on screen updates
End Sub
有人能救我吗？