任何人都可以建议如何为此编写宏... [英] Can any one suggest how to write a macro for this...
本文介绍了任何人都可以建议如何为此编写宏...的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
大家好......
我是宏的新手....我在Excel中有一个要求在宏中完成......我正在努力做到...但是我我无法弄明白该怎么做...任何帮助都会得到赞赏...
我的要求是喜欢这个...
DataInput：（Sheet1）
IN OUT项目单位日期位置
---------------------------- -----------------------------------------
AB XY Item1 No 12 -5-2013 IND
CD BV Item1 No's 12-5-2013 IND
ItemRouting：
物品路线
- --------------------
Item1 Item1Route
Item2 Item2Route
路由：
路由IN OUT RoutingSteps部门
------------------------------------ ------------------
Item1Route AB XY Step1采购
Item1Route AB XY Step2卖
Item2Route CD BV Step1采购
Item2Route CD BV Step2出售
来自以上数据
1.我必须根据项目选择路由（ColumnName）（来自ItemRouting（工作表名称））（来自DataInput（工作表名称））
2.基于从Step1中选择的路由，IN ，Out（来自DataInput）选择Routingsteps，Department（来自路由）
3.基于部门选择我必须复制该特定部门的详细信息（表）...
对于上面的示例，输出将是：
采购（工作表）：
IN OUT项目单位日期位置RoutingStep Department
------------------------------------------------ --------------------------
AB XY Item1 N0's 12-5-2013 IND Step1采购
CD BV项目1 N0's 12-5-2013 IND Step1采购
销售：
IN OUT Ite m单位日期位置路线步骤部门
---------------------------------------- ----------------------------------
AB XY Item1 N0's 12-5-2013 IND Step2 Selling
CD BV Item1 N0's 12-5-2013 IND Step2 Selling
我使用的代码是：
选项显式
Sub FindMacro（）
Dim DataInputRowCount As Long，RoutingRowCount As Long，DRowCount As Long
Dim IpProductType As String，DataIN As String，DataOut As String，Routing As String，Department As String，RoutingStep As String
Dim I As Long，R As Long，Rowno As Long
Sheets（DataInput）。Activate
DataInputRowCount = Cells（ Cells.Rows.Count，5）。End（xlUp）.Row
For I = 2 To DataInputRowCount
Sheets（DataInput）。激活
IpProductType = Cells（I ，5）.Value
DataIN = Cells（I，3）.Value
DataOut = Cells（I，4）.Val ue
Rows（I）.Copy
Rowno = Sheets（ProductRouting）。Columns（1）.Find（IpProductType ,, xlValues，xlWhole）.Row
Routing =表格（ProductRouting）。范围（B& Rowno）.Value
Sheets（Routing）。激活
RoutingRowCount = Cells（Cells.Rows.Count，1）.End（xlUp）.Row
对于R = 2到RoutingRowCount
表（路由）。激活
如果单元格（R，1）.Value =路由和单元格（R，2）.Value = DataIN和单元格（R， 3）.Value = DataOut然后
RoutingStep = Cells（R，4）.Value
Department = Cells（R，5）.Value
Sheets（Department）.Select
DRowCount = Cells（Cells.Rows.Count，1）.End（xlUp）.Row
Range（A& DRowCount + 1）.Select
ActiveSheet.Paste
Range（O & DRowCount + 1）.Value = RoutingStep
Range（P& DRowCount + 1）.Value = Department
End if
Next
Next
End Sub
任何帮助都会得到赞赏...
解决方案
总之，输入数据似乎与您预期的输出数据不匹配;您在输入数据中只有 Item1 ，并且它只映射到 ItemRoute1 ，因此我看不出您如何获得多个采购和那个输入中的一个 Selling 行。
但是，话虽如此，我认为这样的事情可能对你有用;
选项明确
Sub FindMacro（）
Dim inputRow As Integer
Dim procurementRow As Integer
Dim sellingRow As Integer
Dim inputDataSheet As Worksheet
Dim itemRoutingSheet As Worksheet
Dim routingSheet As Worksheet
设置inputDataSheet =表格（ DataInput）
设置itemRoutingSheet =表格（ ItemRouting）
设置routingSheet =表格（ 路由）
采购mentRow = 1
sellingRow = 1
对于inputRow = < span class =code-digit> 2 至 10
Dim itemRoutingRow As Integer
Dim inD As String
Dim outD As String
Dim item As String
Dim unit As String
Dim dateD As String
Dim location As String
inD = inputDataSheet.Cells（inputRow， 1 ）
outD = inputDataSheet.Cells（inputRow， 2 ）
item = inputDataSheet.Cells（inputRow， 3 ）
unit = inputDataSheet.Cells（inputRow， 4 ）
dateD = inputDataSheet.Cells（inputRow， 5 ）
location = inputDataSheet.Cells（inputRow， 6 ）
如果Len（item）< 1 然后退出
对于itemRoutingRow = 2 至 10
Dim routingItem As String
routingItem = itemRoutingSheet.Cells（itemRoutingRow， 1 ）
如果Len（routingItem）< 1 则退出
如果routingItem = item则
Dim routingRow As Integer
Dim routing As String
routing = itemRoutingSheet .Cells（itemRoutingRow， 2 ）
对于routingRow = 2 至 10
如果routing = routingSheet.Cells（routingRow， 1 ）并且inD = routingSheet.Cells（routingRow， 2 ）并且outD = routingSheet.Cells（routingRow， 3 ）然后
Dim outputSheet As Worksheet
Dim department As String
Dim step As String
step = routingSheet.Cells（routingRow，< span class =code-digit> 4 ）
department = routingSheet.Cells（routingRow， 5 ）
设置outputSheet =表格（部门）
Dim row As Integer
如果department = 采购那么
procurementRow = procurementRow + 1
row = procurementRow
否则
soldRow = soldRow + 1
row = sellingRow
结束如果
outputSheet.Cells（row， 1 ）= inD
outputSheet.Cells（row， 2 ）= outD
outputSheet.Cells（row， 3 ）= item
outputSheet。单元格（行， 4 ）= unit
outputSheet.Cells（row， 5 ）= dateD
outputSheet.Cells（row，6 ）= location
outputSheet.Cells（row， 7 ）= step
outputSheet .Cells（row， 8 ）= department
End if
Next routingRow
退出
End如果
下一个itemRoutingRow
下一个inputRow
End Sub
希望这有帮助，
Fredrik
最快的方法是使用 ADODB [ ^ ]，字典 [ ^ ]对象。
更多：
将ADO与Excel数据源一起使用 [ ^ ]
如何使用ADO.NET使用Visual Basic .NET在Excel工作簿中检索和修改记录 [ ^ ]
使用ADO.NET阅读Excel电子表格 [ ^ ]
如何使用Visual Basic使用字典对象 [ ^ ]
在VBA中使用字典类 [ ^ ]
如果我很了解你，你想根据部门名称将数据导出到单独的表格中。
示例：
选项 明确
' 按部门将数据导出到分隔表中
Sub SeparateData（）
Dim wsh As 工作表
Dim i 作为 长，j As 长
Dim sSQL As String ，sTmp As String
Dim dict 作为 对象，keyc 作为 变体，n 作为 变体
Dim adc As ADODB.Connection
Dim rst As ADODB.Recordset
Dim f 作为 ADODB.Field
开启 错误 < span class =code-keyword> GoTo Err_SeparateData
' 创建字典对象以获取DISTINCT部门
设置 dict = CreateObject（ Scripting.Dictionary）
设置 wsh = ThisWorkbook.Worksheets （ 路由）
j = 1
i = 2
while （wsh.Range（ A& i）<> ）
sTmp = wsh.Range（ E& i）
如果 不 dict.Exists（sTmp）然后 dict.Add sTmp，j：j = j + 1
i = i + 1
循环
' open connection
设置 adc = 新 ADODB.Connection
使用 adc
.Provider = Microsoft.Jet.OLEDB.4.0
.ConnectionString = 数据源=& ThisWorkbook.FullName& ;扩展属性='Excel 8.0; HDR =是';
.CursorLocation = adUseClient
。打开
结束 使用
< span class =code-comment>' 查看字典键的集合
keyc = dict.Keys
对于 每个 n 在 keyc
< span class =code-comment>' 忽略添加新工作表的错误（如果不存在）
On 错误 恢复 下一步
设置 wsh = ThisWorkbook.Worksheets（n）
如果 Err<> 0 或 wsh Nothing 然后
设置 wsh = ThisWorkbook.Worksheets .Add（After：= ThisWorkbook.Worksheets（ThisWorkbook.Worksheets.Count））
wsh.Name = n
End 如果
' 捕获错误
< span class =code-keyword> On 错误 GoTo Err_SeparateData
' 构建SQL SELECT语句
sSQL = SELECT di.IN，di.Out，di.Item，di.Unit，di.Date，di.Location，ro.RoutingSteps AS RoutingStep，ro。部门& vbCr& _
FROM（[DataInput
AS di LEFT JOIN [ ItemRouting
Hi All...
I Am New to macro's.... I have a Requirement in Excel to be done in Macro... i am trying to do it... But i am unable to figure out how to do... Any Help will be Appreciated...
My requirement is Like This...
DataInput: (Sheet1)
IN OUT Item Unit Date Location --------------------------------------------------------------------- AB XY Item1 No's 12-5-2013 IND CD BV Item1 No's 12-5-2013 IND
ItemRouting:
Item Routing ---------------------- Item1 Item1Route Item2 Item2Route
Routing:
Routing IN OUT RoutingSteps Department ------------------------------------------------------ Item1Route AB XY Step1 Procurement Item1Route AB XY Step2 Selling Item2Route CD BV Step1 Procurement Item2Route CD BV Step2 Selling
From the above data
1. I Have to Select a Routing(ColumnName)(From ItemRouting(Sheet Name)) based on Item (From DataInput(Sheet name))
2. Based on the Routing Selected From Step1,IN,Out(From DataInput) select the Routingsteps,Department(From Routing)
3.Based on the Department Selected i Have to copy the details in that particular Department(Sheet)...
For the Above example the output will be:
Procurement(Sheet):
IN OUT Item Unit Date Location RoutingStep Department -------------------------------------------------------------------------- AB XY Item1 N0's 12-5-2013 IND Step1 Procurement CD BV Item1 N0's 12-5-2013 IND Step1 Procurement
Selling:
IN OUT Item Unit Date Location RoutingStep Department -------------------------------------------------------------------------- AB XY Item1 N0's 12-5-2013 IND Step2 Selling CD BV Item1 N0's 12-5-2013 IND Step2 Selling
The code which i used is:
Option Explicit
Sub FindMacro()
Dim DataInputRowCount As Long, RoutingRowCount As Long, DRowCount As Long
Dim IpProductType As String, DataIN As String, DataOut As String, Routing As String, Department As String, RoutingStep As String
Dim I As Long, R As Long, Rowno As Long
Sheets("DataInput").Activate
DataInputRowCount = Cells(Cells.Rows.Count, 5).End(xlUp).Row
For I = 2 To DataInputRowCount
Sheets("DataInput").Activate
IpProductType = Cells(I, 5).Value
DataIN = Cells(I, 3).Value
DataOut = Cells(I, 4).Value
Rows(I).Copy
Rowno = Sheets("ProductRouting").Columns(1).Find(IpProductType, , xlValues, xlWhole).Row
Routing = Sheets("ProductRouting").Range("B" & Rowno).Value
Sheets("Routing").Activate
RoutingRowCount = Cells(Cells.Rows.Count, 1).End(xlUp).Row
For R = 2 To RoutingRowCount
Sheets("Routing").Activate
If Cells(R, 1).Value = Routing And Cells(R, 2).Value = DataIN And Cells(R, 3).Value = DataOut Then
RoutingStep = Cells(R, 4).Value
Department = Cells(R, 5).Value
Sheets(Department).Select
DRowCount = Cells(Cells.Rows.Count, 1).End(xlUp).Row
Range("A" & DRowCount + 1).Select
ActiveSheet.Paste
Range("O" & DRowCount + 1).Value = RoutingStep
Range("P" & DRowCount + 1).Value = Department
End If
Next
Next
End Sub
Any Help will be Appreciated...
解决方案
First of all, the input data doesn't seem to match your expected output data; you only have Item1s in the input data, and it only maps to ItemRoute1 so I can't see how you could get more than one Procurement and one Selling line from that input.
But, having said that, I think something like this might do the trick for you;
Option Explicit Sub FindMacro() Dim inputRow As Integer Dim procurementRow As Integer Dim sellingRow As Integer Dim inputDataSheet As Worksheet Dim itemRoutingSheet As Worksheet Dim routingSheet As Worksheet Set inputDataSheet = Sheets("DataInput") Set itemRoutingSheet = Sheets("ItemRouting") Set routingSheet = Sheets("Routing") procurementRow = 1 sellingRow = 1 For inputRow = 2 To 10 Dim itemRoutingRow As Integer Dim inD As String Dim outD As String Dim item As String Dim unit As String Dim dateD As String Dim location As String inD = inputDataSheet.Cells(inputRow, 1) outD = inputDataSheet.Cells(inputRow, 2) item = inputDataSheet.Cells(inputRow, 3) unit = inputDataSheet.Cells(inputRow, 4) dateD = inputDataSheet.Cells(inputRow, 5) location = inputDataSheet.Cells(inputRow, 6) If Len(item) < 1 Then Exit For For itemRoutingRow = 2 To 10 Dim routingItem As String routingItem = itemRoutingSheet.Cells(itemRoutingRow, 1) If Len(routingItem) < 1 Then Exit For If routingItem = item Then Dim routingRow As Integer Dim routing As String routing = itemRoutingSheet.Cells(itemRoutingRow, 2) For routingRow = 2 To 10 If routing = routingSheet.Cells(routingRow, 1) And inD = routingSheet.Cells(routingRow, 2) And outD = routingSheet.Cells(routingRow, 3) Then Dim outputSheet As Worksheet Dim department As String Dim step As String step = routingSheet.Cells(routingRow, 4) department = routingSheet.Cells(routingRow, 5) Set outputSheet = Sheets(department) Dim row As Integer If department = "Procurement" Then procurementRow = procurementRow + 1 row = procurementRow Else sellingRow = sellingRow + 1 row = sellingRow End If outputSheet.Cells(row, 1) = inD outputSheet.Cells(row, 2) = outD outputSheet.Cells(row, 3) = item outputSheet.Cells(row, 4) = unit outputSheet.Cells(row, 5) = dateD outputSheet.Cells(row, 6) = location outputSheet.Cells(row, 7) = step outputSheet.Cells(row, 8) = department End If Next routingRow Exit For End If Next itemRoutingRow Next inputRow End Sub
Hope this helps,
Fredrik
The fastest way to achieve that is to use ADODB[^] with Dictionary[^] object.
More:
Using ADO with Excel Data Sources[^]
How To Use ADO.NET to Retrieve and Modify Records in an Excel Workbook With Visual Basic .NET[^]
Reading an Excel spreadsheet using ADO.NET[^]
How To Use the Dictionary Object with Visual Basic[^]
Using the Dictionary Class in VBA[^]
If i understand you well, you would like to export data into separate sheets based on Department name.
Example:
Option Explicit 'exports data into separates sheets by Department Sub SeparateData() Dim wsh As Worksheet Dim i As Long, j As Long Dim sSQL As String, sTmp As String Dim dict As Object, keyc As Variant, n As Variant Dim adc As ADODB.Connection Dim rst As ADODB.Recordset Dim f As ADODB.Field On Error GoTo Err_SeparateData 'create dictionary object to get DISTINCT departments Set dict = CreateObject("Scripting.Dictionary") Set wsh = ThisWorkbook.Worksheets("Routing") j = 1 i = 2 Do While (wsh.Range("A" & i) <> "") sTmp = wsh.Range("E" & i) If Not dict.Exists(sTmp) Then dict.Add sTmp, j: j = j + 1 i = i + 1 Loop 'open connection Set adc = New ADODB.Connection With adc .Provider = "Microsoft.Jet.OLEDB.4.0" .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 8.0;HDR=yes';" .CursorLocation = adUseClient .Open End With 'go through the collection of dictionary keys keyc = dict.Keys For Each n In keyc 'ignore error to add new sheet, if it doesn't exists On Error Resume Next Set wsh = ThisWorkbook.Worksheets(n) If Err <> 0 Or wsh Is Nothing Then Set wsh = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)) wsh.Name = n End If 'catch errors On Error GoTo Err_SeparateData 'build SQL SELECT statement sSQL = "SELECT di.IN, di.Out, di.Item, di.Unit, di.Date, di.Location, ro.RoutingSteps AS RoutingStep, ro.Department" & vbCr & _ "FROM ([DataInput
AS di LEFT JOIN [ItemRouting
这篇关于任何人都可以建议如何为此编写宏...的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
