[英]How write an Excel-VBA code to update an excel sheet with data that is exported from a program?
这里是业余编码员，我正在尝试编写一个Excel-VBA代码，该代码可以使用来自数据转储的较新信息自动更新行（原始数据来自先前的转储，只是想保持excel工作表的最新状态）数据转储，并使用户输入数据与数据转储数据对齐）。 该代码应在每一行中在同一列全片重复数据的前4列比较值，如果发现重复行具有相同的数据，将用新的数据替换原始行只是一个例子，我捏造的。 因此，在此示例中，代码将第8行的EFG列替换为第1行的EFG列，因为它们均已更改，但将所有用户输入数据保留为较新的数据。 第5行FG列也是如此，由第11行FG取代。 等等。 然后根据列AD中的重复数据删除所有重复的行。 我已经在Excel-VBA中编写了一些非常基本的代码，但是这一代码远远超出了我的能力范围，因此我什至不知道从哪里开始。 任何建议或简单的起点都会有所帮助！
我最近对在Excel VBA中查找重复项进行了一些测试。 这是StackOverflow上的一个常见问题，使用各种方法，答案范围从笨拙到精致。
恐怕OP无法提供足够的信息来回答他/她的特定问题，但是显然他/她将需要编写例程来管理重复项。 因此，我希望下面的代码能有所帮助。
该测试涉及获取500,000个项目的数据集，将唯一值写入新表并将这些值存储在array或Collection 。 我记录了使用5种不同方法处理任务的时间： Range.AdvancedFilter ， Collection ，Array比较， Range.RemoveDuplicates和Application.Match 。 这些项目仅存储在一列中，并且是具有500个唯一值的字符串（因此没有日期可以使事情变得更尴尬）。 速度顺序的结果是：
优点：
缺点：
Range （因此可能需要隐藏的工作表） 优点：
worksheet效果很好 缺点：
String作为唯一键（因此可能需要强制转换，如果该键最初是Integer或Long Integer ，并且您忘记将其转换为String进行查找，则可能会发生错误） Dictionary对象将绕过此问题）。 优点：
Range删除重复项，这是一项很棒的技术 缺点：
AdvancedFilter ，没有进一步的编码就无法识别匹配项。 优点：
缺点：
Worksheet更加困难，因为结果数组是一维的，因此管理行可能会成为问题。 如果只有VBA让你ReDim第一维... 优点：
缺点：
因此，我想在管理重复项时很难超越AdvancedFilters和Collections ，但是没人能容忍丑陋的事物，所以请选择。
如果您有兴趣，测试代码如下：
Option Explicit
Private mTimer As clsTimer
Private mDataRanges As Collection
Private Const ADV_FILTER_KEY As String = "AdvancedFilter"
Private Const COLLECTION_KEY As String = "Collection"
Private Const ARRAY_COMP_KEY As String = "Array Comparison"
Private Const REMOVE_DUPES_KEY As String = "RemoveDuplicates"
Private Const MATCH_KEY As String = "Match"
Public Sub RunMe()
Dim srcSht As Worksheet
Dim outSht As Worksheet
Dim lastCell As Range
Dim loc As clsRanges
'Initialise
Set mTimer = New clsTimer
'Idenfity the source data
Set srcSht = ThisWorkbook.Worksheets("SourceData")
Set outSht = ThisWorkbook.Worksheets("UniqueList")
Set lastCell = srcSht.Cells(srcSht.Rows.count, "A").End(xlUp)
'Prepare the output sheet
outSht.Cells.Clear
outSht.Cells(1, 1).Value = "Type"
outSht.Cells(2, 1).Value = "Secs"
'Define the source and output ranges
Set mDataRanges = New Collection
Set loc = New clsRanges
loc.Create lastCell, outSht, 2, True
mDataRanges.Add loc, ADV_FILTER_KEY
Set loc = New clsRanges
loc.Create lastCell, outSht, 3
mDataRanges.Add loc, COLLECTION_KEY
Set loc = New clsRanges
loc.Create lastCell, outSht, 4
mDataRanges.Add loc, ARRAY_COMP_KEY
Set loc = New clsRanges
loc.Create lastCell, outSht, 5
mDataRanges.Add loc, REMOVE_DUPES_KEY
Set loc = New clsRanges
loc.Create lastCell, outSht, 6
mDataRanges.Add loc, MATCH_KEY
'Find the unique values using different methods
UsingAdvFilter
UsingCollection
UsingArrayComparison
UsingRemoveDuplicates
UsingMatch
End Sub
Private Sub UsingAdvFilter()
Dim loc As clsRanges
Dim v As Variant
Dim rng As Variant
Dim srcRange As Range
Dim outRange As Range
'Start the clock
mTimer.StartCounter
'Run the filter to write unique values
Set loc = mDataRanges(ADV_FILTER_KEY)
loc.SourceRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=loc.OutputRange, unique:=True
'Read the unique values into an array
v = loc.OutputRange.CurrentRegion.Resize(, 1).Value
'Stop the clock
loc.OutputRange.Offset(-1).Value = Round(mTimer.TimeElapsed / 1000, 2)
'Write the heading
loc.OutputRange.Offset(-2).Value = ADV_FILTER_KEY
loc.OutputRange.EntireColumn.AutoFit
End Sub
Private Sub UsingCollection()
Dim col As Collection
Dim data As Variant
Dim key As String
Dim item As Variant
Dim v() As Variant
Dim i As Long
Dim loc As clsRanges
'Start the clock
mTimer.StartCounter
'Read the source data into an array
Set loc = mDataRanges(COLLECTION_KEY)
data = loc.SourceRange.Value2
'Prepare error handler to trap duplicate keys
On Error Resume Next
'Loop through the data array to find unique values
Set col = New Collection
For i = 1 To UBound(data, 1)
'Define the key (must be a String)
key = CStr(data(i, 1))
'Test if collection already contains the key
'If it doesn't an error 5 will be thrown
item = col(key)
If Err.Number = 5 Then 'key doesn't exist
col.Add data(i, 1), key
Err.Clear
ElseIf Err.Number <> 0 Then 'trap any unplanned errors
MsgBox Err.Description
End
End If
Next
'Restore the error handler
On Error GoTo 0
'Read the unique values into an array
ReDim v(1 To col.count, 1 To 1)
i = 1
For Each item In col
v(i, 1) = item
i = i + 1
Next
'Write the unique values
loc.OutputRange.Resize(UBound(v, 1)).Value = v
'Stop the clock
loc.OutputRange.Offset(-1).Value = Round(mTimer.TimeElapsed / 1000, 2)
'Write the heading
loc.OutputRange.Offset(-2).Value = COLLECTION_KEY
loc.OutputRange.EntireColumn.AutoFit
End Sub
Private Sub UsingArrayComparison()
Dim loc As clsRanges
Dim data As Variant
Dim tmp() As Variant
Dim v() As Variant
Dim i As Long
Dim c As Long
Dim count As Long
Dim isUnique As Boolean
'Start the clock
mTimer.StartCounter
'Read the source data into an array
Set loc = mDataRanges(ARRAY_COMP_KEY)
data = loc.SourceRange.Value2
'Dimension the array which will temporarily store unique values
ReDim tmp(1 To UBound(data, 1))
'Set the unique counter - use 0 to prevent the loop running on first item.
count = 0
'Loop through the data array
For i = 1 To UBound(data, 1)
'Test if value is already contained in unique list
'by iterating through it until a match is found
isUnique = True
For c = 1 To count
If data(i, 1) = tmp(c) Then
isUnique = False
Exit For
End If
Next
'If no match is found then add it to the temporary array
'and increment the count
If isUnique Then
count = count + 1
tmp(count) = data(i, 1)
End If
Next
'Trim the temporary array to the unique count size
ReDim Preserve tmp(1 To count)
'Unfortunately we can't write a one-dimensional array to
'a Worksheet (without using some form of Transposition)
'so we'll copy it to a two-dimensional one.
'It would be easier if we could just Dim the tmp array
'in two dimensions, but ReDim only allows us to adjust the
'last dimension (ie column), so we can't deal with rows.
ReDim v(1 To count, 1 To 1)
For i = 1 To count
v(i, 1) = tmp(i)
Next
'Write the unique values
loc.OutputRange.Resize(count).Value = v
'Stop the clock
loc.OutputRange.Offset(-1).Value = Round(mTimer.TimeElapsed / 1000, 2)
'Write the heading
loc.OutputRange.Offset(-2).Value = ARRAY_COMP_KEY
loc.OutputRange.EntireColumn.AutoFit
End Sub
Private Sub UsingRemoveDuplicates()
Dim loc As clsRanges
Dim rng As Range
Dim v As Variant
Dim count As Long
'Start the clock
mTimer.StartCounter
'Resize the output range to match the source data range
Set loc = mDataRanges(REMOVE_DUPES_KEY)
Set rng = loc.OutputRange.Resize(loc.SourceRange.Rows.count)
'Turn off screen updating to keep our test fair
Application.ScreenUpdating = False
'Write the full source data to the output sheet
rng.Value = loc.SourceRange.Value2
'Run the remove duplicates routine
rng.RemoveDuplicates 1, xlNo
'Restore screen updating
Application.ScreenUpdating = True
'Calculate size of range without the duplicates
count = rng.Cells(rng.Rows.count, 1).End(xlUp).Row - loc.OutputRange.Row + 1
'Read the values into an array
v = loc.OutputRange.Resize(count).Value
'Stop the clock
loc.OutputRange.Offset(-1).Value = Round(mTimer.TimeElapsed / 1000, 2)
'Write the heading
loc.OutputRange.Offset(-2).Value = REMOVE_DUPES_KEY
loc.OutputRange.EntireColumn.AutoFit
End Sub
Private Sub UsingMatch()
Dim data As Variant
Dim lastPos As Long
Dim searchRange As Range
Dim isUnique As Boolean
Dim loc As clsRanges
Dim count As Long
Dim i As Long
Dim tmp() As Variant
Dim v() As Variant
'Start the clock
mTimer.StartCounter
'Read the source data into an array
Set loc = mDataRanges(MATCH_KEY)
data = loc.SourceRange.Value2
'Dimension the array which will temporarily store unique values
ReDim tmp(1 To UBound(data, 1))
'Prepare the loop parameters
lastPos = UBound(data, 1)
count = 0
For i = 1 To lastPos
If i = lastPos Then 'no need to look for a match as it's the last one
isUnique = True
Else
'Define the search range to be one below the current item to the end.
Set searchRange = loc.SourceRange.Cells(i + 1, 1).Resize(lastPos - i)
isUnique = IsError(Application.Match(data(i, 1), searchRange, 0))
End If
'If there's no match, add the item to our uniques array
If isUnique Then
count = count + 1
tmp(count) = data(i, 1)
End If
Next
'Trim the temporary array to the unique count size
ReDim Preserve tmp(1 To count)
'Same one-dimensional array issue as array method so transpose.
ReDim v(1 To count, 1 To 1)
For i = 1 To count
v(i, 1) = tmp(i)
Next
'Write the unique values
loc.OutputRange.Resize(count).Value = v
'Stop the clock
loc.OutputRange.Offset(-1).Value = Round(mTimer.TimeElapsed / 1000, 2)
'Write the heading
loc.OutputRange.Offset(-2).Value = MATCH_KEY
loc.OutputRange.EntireColumn.AutoFit
End Sub
...为了完整clsRanges ，这是clsRanges代码：
Private mSrcRange As Range
Private mOutRange As Range
Public Sub Create(srcLastCell As Range, outSht As Worksheet, outCol As Long, Optional incHeader As Boolean = False)
Dim ws As Worksheet
Dim r As Long
Dim c As Long
Set ws = srcLastCell.Worksheet
r = IIf(incHeader, 1, 2)
c = srcLastCell.Column
Set mSrcRange = ws.Range(ws.Cells(r, c), srcLastCell)
Set mOutRange = outSht.Cells(3, outCol)
End Sub
Public Property Get SourceRange() As Range
Set SourceRange = mSrcRange
End Property
Public Property Get OutputRange() As Range
Set OutputRange = mOutRange
End Property
（Excel-VBA）在活动工作表中导入特定数据（在后台）
[英](Excel-VBA) Specific data import (on the background) in the active sheet
Excel-VBA：使用来自不同工作表的数据向表中添加多行
[英]Excel-VBA: Add Multiple Rows to Table with Data from different sheet
如何基于Excel-VBA中的数据自动调整导出/报表中的行
[英]How to automatically adjust rows in export/report sheet based on the data in Excel-VBA
如何将 Excel 相关 BOM 列表内容导入 Excel-VBA 中的 excel 工作表？
[英]How to import Excel related BOM-list content into a excel sheet in Excel-VBA?
Excel-VBA：如何改进该代码（范围内的行中文本功能）
[英]Excel-VBA: how to improve that code (text in rows feature for a range)
声明:本站的技术帖子网页，遵循CC BY-SA 4.0协议，如果您需要转载，请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.