vba 将非连续命名范围放入数组，然后放入不同工作表中的行
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/25365547/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Non-contiguous named range into an array, then into row in different sheet
提问by Greg
I'm trying to get data posted from a non-contiguous range into a row in a separate sheet. Before I built the non-contiguous range, this code worked perfectly. I've tried several things to loop through, but nothing I tried will work. It won't copy the ranged data as it sits. It's been years since I've actually done any coding and my re-learning curve seems to be holding me back.... the logic just isn't coming to me. Help!
我正在尝试将数据从非连续范围发布到单独工作表中的一行中。在我构建非连续范围之前，这段代码运行良好。我已经尝试了几件事情来循环，但我尝试过的任何事情都不起作用。它不会复制远程数据。自从我真正完成任何编码以来已经有很多年了，我的重新学习曲线似乎阻碍了我......逻辑只是不来找我。帮助！
Sub UpdateLogWorksheet()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myCopy As Range
Dim myTest As Range
Dim myData As Range
Dim lRsp As Long
Set inputWks = Worksheets("Input")
Set historyWks = Worksheets("DataEntry")
oCol = 3 'order info is pasted on data sheet, starting in this column
'check for duplicate VIN in database
If inputWks.Range("CheckVIN") = True Then
lRsp = MsgBox("VIN already in database. Update record?", vbQuestion + vbYesNo, "Duplicate VIN")
If lRsp = vbYes Then
UpdateLogRecord
Else
MsgBox "Please change VIN to a unique number."
End If
Else
'cells to copy from Input sheet - some contain formulas
Set myCopy = inputWks.Range("VehicleEntry") 'non-contiguous named range
With historyWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
With inputWks
'mandatory fields are tested in hidden column
Set myTest = myCopy.Offset(0, 2)
If Application.Count(myTest) > 0 Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
End With
With historyWks
'enter date and time stamp in record
With .Cells(nextRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
'enter user name in column B
.Cells(nextRow, "B").Value = Application.UserName
'copy the vehicle data and paste onto data sheet
myCopy.Copy
.Cells(nextRow, oCol).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
End With
'clear input cells that contain constants
Clear
End If
End Sub
采纳答案by Siddharth Rout
This is an exampleto explain how to achieve what you want. Please amend the code to suit your needs.
这是一个解释如何实现您想要的示例的示例。请修改代码以满足您的需求。
Let's say, I have a Sheet1which looks like as shown below. The colored cells make up from my non contiguous range.
比方说，我有一个Sheet1如下所示。彩色单元格由我的非连续范围组成。
Now paste the code given below in a module and run it. The output will be generated in Sheet2and Sheet3
现在将下面给出的代码粘贴到一个模块中并运行它。输出将在Sheet2和Sheet3
Code
代码
Sub Sample()
Dim rng As Range, aCell As Range
Dim MyAr() As Variant
Dim n As Long, i As Long
'~~> Change this to the relevant sheet
With Sheet1
'~~> Non Contiguous range
Set rng = .Range("A1:C1,B3:D3,C5:G5")
'~~> Get the count of cells in that range
n = rng.Cells.Count
'~~> Resize the array to hold the data
ReDim MyAr(1 To n)
n = 1
'~~> Store the values from that range into
'~~> the array
For Each aCell In rng.Cells
MyAr(n) = aCell.Value
n = n + 1
Next aCell
End With
'~~> Output the data in Sheet
'~~> Vertically Output to sheet 2
Sheet2.Cells(1, 1).Resize(UBound(MyAr), 1).Value = _
Application.WorksheetFunction.Transpose(MyAr)
'~~> Horizontally Output to sheet 3
Sheet3.Cells(1, 1).Resize(1, UBound(MyAr)).Value = _
MyAr
End Sub
Vertical Output
垂直输出
Horizontal Output
水平输出
Hope the above example helps you in achieving what you want.
希望上面的例子可以帮助你实现你想要的。
