vba 根据单元格值将数据从一张工作表复制并排序到另一张工作表
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/20899120/
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
Copy and sort data from one sheet to another, based on cell values
提问by johnmelvin
I have searched a lot of similar topics and have had some help but I cant find a way to do what I need (probably because of my limited experience with excel and vba), so here it goes:
我搜索了很多类似的主题并得到了一些帮助，但我找不到一种方法来做我需要的事情（可能是因为我对 excel 和 vba 的经验有限），所以这里是：
I have a (Source)sheet 'offers' , which is populated daily, with the columns below:
我有一个（源）表 'offers' ，每天填充，包含以下列：
columns: b c d e f g
header: offercode issue dt worktype customer sent dt confirmation dt
xxx.xx. 1/1/14 MI john 1/1/14 3/1/14
aaa.aa. 1/1/14 MD bob 2/1/14
bbb.bb 2/1/14 SI peter 2/1/14 3/1/14
what I need is to copy all rows that get a confirmation date (not blank) in another sheet"production orders"(destination) where I generate production order codes and input other kind of data :
我需要的是将所有获得确认日期（非空白）的行复制到另一张“生产订单”（目的地）中，我在其中生成生产订单代码并输入其他类型的数据：
columns: b c d e f g
header: offercode productioncode worktype start end confirmation dt
xxx.xx. 1/1/14 MI 5/1/14 3/1/14
bbb.bb 2/1/14 SI 6/1/14 3/1/14
note that column b and b & c contain formulas (generates offer codes)
请注意，列 b 和 b & c 包含公式（生成报价代码）
my problem is that data is populated daily, and offers(Source Sheet) should be sorted by issue date and once they get confirmed(input confirmation date->non blank) they should be copied in the other sheet but sorted (or polulate the next empty row) by confirmation date eg:
我的问题是每天都会填充数据，并且报价（源表）应该按发布日期排序，一旦它们得到确认（输入确认日期-> 非空白），它们应该被复制到另一张表中但排序（或填充下一个空行）按确认日期，例如：
columns: b c d e f g
header: offercode productioncode worktype start end confirmation dt
xxx.xx. XX.XXX. MI 5/1/14 3/1/14
bbb.bb BB.BBB SI 6/1/14 3/1/14
aaa.aa. AA>AAA MD 4/1/14
another issue is how often or when is the second (Destination Sheet) list refreshs with new data, my guess is that a control button click after every data entry instance would work (and make sure that the list is up to date)
另一个问题是第二个（目标表）列表多久或何时用新数据刷新，我的猜测是在每个数据输入实例后单击控制按钮会起作用（并确保列表是最新的）
thank you in advance,
先感谢您，
Angelos
安杰洛斯
回答by johnmelvin
So, this is what is working for me right now, its all based on @simoco's code: I am checking in it for operationalconsistency, but the code works fine.
所以，这就是现在对我有用的东西，它全部基于@simoco 的代码：我正在检查它的操作一致性，但代码工作正常。
It copies and pastes only the columns of (my) interest where I need it and then sorts a dynamic range.
它仅复制和粘贴（我的）感兴趣的列到我需要的地方，然后对动态范围进行排序。
Sub copycolumnsonly()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim lastrow1 As Long
Dim lastrow2 As Long
Dim j As Long
Dim i As Long
Dim rng As Range
'set correct name of the sheet with your data'
Set sh1 = ThisWorkbook.Worksheets("D??ó????ó")
'set correct name of the sheet where you need to paste data'
Set sh2 = ThisWorkbook.Worksheets("?í????ó Dá?á?ù??ó")
'determining last row of your data in file áááááááá.xlsx'
lastrow1 = sh1.Range("C" & sh1.Rows.Count).End(xlUp).Row
'determining last row of your data in file ????????.xls'
lastrow2 = sh2.Range("F" & sh2.Rows.Count).End(xlUp).Row
'clear content in sheet2
sh2.Range("F11:F" & lastrow2).ClearContents
sh2.Range("G11:G" & lastrow2).ClearContents
sh2.Range("N11:N" & lastrow2).ClearContents
'suppose that in sheet2 data starts from row #11
j = 11
For i = 0 To lastrow1
Set rng = sh1.Range("G11").Offset(i, 0)
'check whether value in column D is not empy
If Not (IsNull(rng) Or IsEmpty(rng)) Then
sh1.Range("B" & i + 11).Copy
sh2.Range("F" & j).PasteSpecial xlPasteValues
sh1.Range("g" & i + 11).Copy
sh2.Range("G" & j).PasteSpecial xlPasteValues
sh1.Range("K" & i + 11).Copy
sh2.Range("N" & j).PasteSpecial xlPasteValues
j = j + 1
End If
Next i
Application.CutCopyMode = False
'sorting the new list, recorded macro tweaked to use a dynamic named range
ActiveWorkbook.Worksheets("?í????ó Dá?á?ù??ó").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("?í????ó Dá?á?ù??ó").Sort.SortFields.Add Key:=Range( _
"G:G"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("?í????ó Dá?á?ù??ó").Sort
.SetRange Range("PRODUCTIONORDERS")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
回答by johnmelvin
this is what I have come up with as a completly different approach,
这是我想出的完全不同的方法，
I would greatly appreciate it if you could check it for error handling, or invalid input from users etc (see comments in code) `
如果您可以检查它的错误处理或来自用户的无效输入等，我将不胜感激（请参阅代码中的注释）`
Sub ActiveToLastRow()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim activerow As Long
Dim lastrow2 As Long
Dim rng As Range
Dim confirmation As Range
'set correct name of the sheet with your data
Set sh1 = ThisWorkbook.Worksheets("D??ó????ó")
'set correct name of the sheet where you need to paste data
Set sh2 = ThisWorkbook.Worksheets("?í????ó Dá?á?ù??ó")
'making sure the user selects the correct offercode via inputbox to get its rownumber --> see activerow variable
Set rng = Application.InputBox("dialeje prosfora", "epilogh prosforas", Type:=8)
'getting the information(confirmation date) via input box form the user
Dim TheString As String
Dim TheDate As Date
TheString = Application.InputBox("Enter A Date", "epibebaiwsh anathesis")
If IsDate(TheString) Then
TheDate = DateValue(TheString)
Else
MsgBox "Invalid date"
'need to end sub if user input is invalid
End If
'determining active row of your data in file áááááááá.xlsx where data input occurs <-- user input via 1st input box
activerow = rng.Row
Set confirmation = sh1.Range("G" & activerow)
confirmation.Value = TheDate
'determining last row of your data in file ????????.xls'
lastrow2 = sh2.Range("F" & sh2.Rows.Count).End(xlUp).Row
'determining what to copy and where
sh1.Range("B" & activerow).Copy
sh2.Range("F" & lastrow2 + 1).PasteSpecial xlPasteValues
sh1.Range("g" & activerow).Copy
sh2.Range("G" & lastrow2 + 1).PasteSpecial xlPasteValues
sh1.Range("K" & activerow).Copy
sh2.Range("N" & lastrow2 + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'activating destination sheet for testing purposes
sh2.Activate
End Sub`
回答by Ric D
It looks like you simply need to copy over only those rows with a value in the "Confirmation Date" column - if I read the above correctly. If the sheet with the daily updates is called "First", and the resultant sheet with only the confirmed orders is called "Second", the following should do it...
看起来您只需要复制那些在“确认日期”列中具有值的行 - 如果我正确阅读了上述内容。如果每天更新的工作表称为“第一”，而只有已确认订单的结果工作表称为“第二”，则应执行以下操作...
Sub Macro1() ' ' Macro1 Macro '
子宏 1() ' ' 宏 1 宏 '
' lastRow = 10 ' hard coded here; use whatever technique to get real value.
' lastRow = 10 '在这里硬编码；使用任何技术来获得真正的价值。
'Copy over the headers to the new sheet
Sheets("First").Select
Rows("1:1").Select
Selection.Copy
Sheets("Second").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("A:F").ColumnWidth = 9
Columns("G:G").ColumnWidth = 12
Sheets("First").Select
' Range("G1").Select
Confirm_Count = 0
For Row = 1 To lastRow
If Len(Range("G1").Offset(Row, 0)) > 1 Then
Rows(Row + 1).Select
Selection.Copy
Sheets("Second").Select
Confirm_Count = Confirm_Count + 1
Range("A1").Offset(Confirm_Count, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("First").Select
End If
Next Row
End Sub
结束子
