Question

我创建了自动填充偏移功能，以将数据添加到列表中。现在，我需要将插入的数据转换为与上面的单元格相同的格式。我认为有一些较短的代码可以做到这一点。我的无论如何都没有工作。数据分散在整个工作表中。

Option Explicit
Sub data_entry()

Application.ScreenUpdating = False

Dim ItemNumber As String
Dim ItemType As String
Dim Issues As String
Dim InventoryValue As String

ItemNumber = InputBox("Please enter Item Number", "Item Number", "Type here")
ItemType = InputBox("Please enter Item Type", "Item Type", "Type here")
Issues = InputBox("Please enter Number of Issues", "Issues", "Type here")
InventoryValue = InputBox("Please enter Inventory Value", "Inventory Value", "Type here")

Range("A2").Activate

Do

If ActiveCell.Value = "" Then Exit Do
ActiveCell.Offset(1, 0).Activate

Loop

ActiveCell.Value = ItemNumber
'ActiveCell.Offset(-1, 0).Copy
'ActiveCell.Offset(1, 0).PasteSpecial Paste:=xlPasteFormats

ActiveCell.Offset(0, 5).Value = ItemType
'ActiveCell.Offset(-1, 0).Copy
'ActiveCell.Offset(1, 0).PasteSpecial Paste:=xlPasteFormats

ActiveCell.Offset(0, 7).Value = Issues
'ActiveCell.Offset(-1, 7).Copy
'ActiveCell.Offset(1, 0).PasteSpecial Paste:=xlPasteFormats

ActiveCell.Offset(0, 8).Value = InventoryValue
'ActiveCell.Offset(-1, 8).Copy
'ActiveCell.Offset(1, 0).PasteSpecial Paste:=xlPasteFormats


End Sub

Answer 1

我相信以下内容将在不激活单元和没有执行Do Loop的情况下达到您的预期结果，这两者都会不可避免地导致性能下降：

Sub Data_Entry()
Dim ws As Worksheet: Set ws = ThisWorkbook.ActiveSheet 'or you could be more explicit and use: ThisWorkbook.Worksheets("Sheet1")
'declare and set the worksheet being used, amend as required.
Application.ScreenUpdating = False

Dim ItemNumber As String
Dim ItemType As String
Dim Issues As String
Dim InventoryValue As String

ItemNumber = InputBox("Please enter Item Number", "Item Number", "Type here")
ItemType = InputBox("Please enter Item Type", "Item Type", "Type here")
Issues = InputBox("Please enter Number of Issues", "Issues", "Type here")
InventoryValue = InputBox("Please enter Inventory Value", "Inventory Value", "Type here")

NextRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
'find the next free row in Column A

ws.Range("A" & NextRow).Value = ItemNumber
'another way to reference a cell would be: ws.Cells(NextRow, 1).Value = ItemNumber
ws.Range("F" & NextRow).Value = ItemType
ws.Range("H" & NextRow).Value = Issues
ws.Range("I" & NextRow).Value = InventoryValue


ws.Range("A" & NextRow - 1 & ":I" & NextRow - 1).Copy
'Copy above row from Columns A to I
ws.Range("A" & NextRow & ":I" & NextRow).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'paste the formating to new row Columns A to I
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Answer 2

尝试一下：

Option Explicit
Sub data_entry()

Application.ScreenUpdating = False

Dim ItemNumber As String
Dim ItemType As String
Dim Issues As String
Dim InventoryValue As String

ItemNumber = InputBox("Please enter Item Number", "Item Number", "Type here")
ItemType = InputBox("Please enter Item Type", "Item Type", "Type here")
Issues = InputBox("Please enter Number of Issues", "Issues", "Type here")
InventoryValue = InputBox("Please enter Inventory Value", "Inventory Value", "Type here")

Range("A2").Activate

Do

If ActiveCell.Value = "" Then Exit Do
ActiveCell.Offset(1, 0).Activate

Loop

ActiveCell.Value = ItemNumber
'ActiveCell.Offset(-1, 0).Copy
Range(ActiveCell, ActiveCell.Offset(-1, 0)).Copy
'ActiveCell.Offset(1, 0).PasteSpecial Paste:=xlPasteFormats
Sheets("NameSheet").Range(ActiveCell, ActiveCell.Offset(1, 0)).PasteSpecial xlPasteValuesAndNumberFormats
Sheets("NameSheet").Range(ActiveCell, ActiveCell.Offset(1, 0)).PasteSpecial PasteSpecial xlPasteFormats

ActiveCell.Offset(0, 5).Value = ItemType
'ActiveCell.Offset(0, 5).Copy
Range(ActiveCell, ActiveCell.Offset(-1, 0)).Copy
'ActiveCell.Offset(1, 0).PasteSpecial Paste:=xlPasteFormats
Sheets("NameSheet").Range(ActiveCell, ActiveCell.Offset(1, 0)).PasteSpecial xlPasteValuesAndNumberFormats
Sheets("NameSheet").Range(ActiveCell, ActiveCell.Offset(1, 0)).PasteSpecial PasteSpecial xlPasteFormats

ActiveCell.Offset(0, 7).Value = Issues
'ActiveCell.Offset(-1, 7).Copy
Range(ActiveCell, ActiveCell.Offset(-1, 7)).Copy
'ActiveCell.Offset(1, 0).PasteSpecial Paste:=xlPasteFormats
Sheets("NameSheet").Range(ActiveCell, ActiveCell.Offset(1, 0)).PasteSpecial xlPasteValuesAndNumberFormats
Sheets("NameSheet").Range(ActiveCell, ActiveCell.Offset(1, 0)).PasteSpecial PasteSpecial xlPasteFormats

ActiveCell.Offset(0, 8).Value = InventoryValue
'ActiveCell.Offset(-1, 8).Copy
Range(ActiveCell, ActiveCell.Offset(-1, 8)).Copy
'ActiveCell.Offset(1, 0).PasteSpecial Paste:=xlPasteFormats
Sheets("NameSheet").Range(ActiveCell, ActiveCell.Offset(1, 0)).PasteSpecial xlPasteValuesAndNumberFormats
Sheets("NameSheet").Range(ActiveCell, ActiveCell.Offset(1, 0)).PasteSpecial PasteSpecial xlPasteFormats


End Sub

我无法将数据转换为适当的格式

2 个答案: