本文介绍了你认为你能简化我的代码吗的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
两者都有一列:位置ID
这些是我认为编应该执行的步骤:
提示用户选择2个文件的位置.从用户选择的文件中读取数据.相应地打开预设的Excel模板粘贴项>>保存吧！
最终输出:两个工作簿中相同的位置ID 在彼此相邻的1张纸中..
可能的?请在这里指导我..新手..完成我的研究:)
**我可以发布文件的图片，但是我认为您不能在这里
Both has a column called : Location ID
These are the step I think the prog should do :
Promp user to select location of 2 file >> Read data from the user selected file >> Open pre-set Excel template paste item accordingly >> Save it!
Final Output: Same Location ID from both workbook in 1 sheet beside each other..
Possible? please guide me..newbie here..done my research :)
**i can post picture of the files but i don''t think you can on here
推荐答案
Public Interface ICombMerge
Property TemplateFile() As String
Property HeaderTop() As String
Property HeaderBottom() As String
Property ReportTop() As String
Property ReportBottom() As String
Property DestFile() As String
Function GetMyFileName(Optional ByVal sTitle As String = "Select file...", Optional ByVal sInitialDir As String = "C:\") As String
Function SaveAsFileName(Optional ByVal sTitle As String = "Save As ...", Optional ByVal sInitialDir As String = "C:\") As String
Function MergeFiles() As Long
End Interface TCombMerge.vb文件的内容(类模块):
The content of TCombMerge.vb file (class module):
Public Class TCombMerge
Implements ICombMerge
Dim sHT As String = String.Empty 'header top
Dim sHB As String = String.Empty 'header bottom
Dim sRT As String = String.Empty 'report top
Dim sRB As String = String.Empty 'report bottom
Dim sTF As String = String.Empty 'template file
Dim sDF As String = String.Empty 'destination file
Public Sub New()
'almost all variables already set
sTF = Application.StartupPath & "\Templates\MergedReport.xls"
sDF = Application.StartupPath & "\Output\" & DateTime.Today & "_MergedReport.xls"
End Sub
Public Sub New(ByVal _tf As String, ByVal _ht As String, ByVal _hb As String, ByVal _rt As String, ByVal _rb As String, ByVal _df As String)
sTF = _tf
sHT = _ht
sHB = _hb
sRT = _rt
sRB = _rb
sDF = _df
End Sub
Property TemplateFile() As String Implements ICombMerge.TemplateFile
Get
Return sTF
End Get
Set(ByVal _tf As String)
sTF = _tf
End Set
End Property
Property DestFile() As String Implements ICombMerge.DestFile
Get
Return sDF
End Get
Set(ByVal _df As String)
sDF = _df
End Set
End Property
Property HeaderTop() As String Implements ICombMerge.HeaderTop
Get
Return sHT
End Get
Set(ByVal _ht As String)
sHT = _ht
End Set
End Property
Property HeaderBottom() As String Implements ICombMerge.HeaderBottom
Get
Return sHB
End Get
Set(ByVal _hb As String)
sHB = _hb
End Set
End Property
Property ReportTop() As String Implements ICombMerge.ReportTop
Get
Return sRT
End Get
Set(ByVal _rt As String)
sRT = _rt
End Set
End Property
Property ReportBottom() As String Implements ICombMerge.ReportBottom
Get
Return sRB
End Get
Set(ByVal _rb As String)
sRB = _rb
End Set
End Property
Function GetMyFileName(Optional ByVal sTitle As String = "Select file...", Optional ByVal sInitialDir As String = "C:\") As String Implements ICombMerge.GetMyFileName
Dim dlgOpen As OpenFileDialog = Nothing, dlgRes As DialogResult = DialogResult.Cancel
Dim sFileName As String = String.Empty
Try
dlgOpen = New OpenFileDialog()
With dlgOpen
.Title = sTitle
.InitialDirectory = sInitialDir
.CheckFileExists = True
.CheckPathExists = True
.Filter = "Excel files (*.xls)|*.xls"
.FilterIndex = 0
.DefaultExt = "xls"
.AddExtension = True
.Multiselect = False
dlgRes = .ShowDialog
End With
If dlgRes = DialogResult.Cancel Then Exit Try
sFileName = dlgOpen.FileName
Catch ex As Exception
MsgBox(ex.Message, MsgBoxStyle.Exclamation, "Error...")
Finally
dlgOpen = Nothing
End Try
Return sFileName
End Function
Function SaveAsFileName(Optional ByVal sTitle As String = "Save As ...", Optional ByVal sInitialDir As String = "C:\") As String Implements ICombMerge.SaveAsFileName
Dim dlgSave As SaveFileDialog = Nothing, dlgRes As DialogResult = DialogResult.Cancel
Dim sFileName As String = String.Empty
Try
dlgSave = New SaveFileDialog()
With dlgSave
.Title = sTitle
.InitialDirectory = sInitialDir
.CheckFileExists = False
.CheckPathExists = True
.OverwritePrompt = True
.Filter = "Excel files (*.xls)|*.xls"
.FilterIndex = 0
.DefaultExt = "xls"
.AddExtension = True
dlgRes = .ShowDialog
End With
If dlgRes = DialogResult.Cancel Then Exit Try
sFileName = dlgSave.FileName
Catch ex As Exception
MsgBox(ex.Message, MsgBoxStyle.Exclamation, "Error...")
Finally
dlgSave = Nothing
End Try
Return sFileName
End Function
Function MergeFiles() As Long Implements ICombMerge.MergeFiles
Dim retVal As Long = 0, i As Long = 0, j As Long = 0
Dim sFiles() As String = Nothing, oExc As Object = Nothing
Dim oWbkSrc As Object = Nothing, oWbkDst As Object = Nothing
Dim oWshSrc As Object = Nothing, oWshDst As Object = Nothing
'retval is used to return value of function
'=0: OK
'>0: Error occured
Try
If sHT = String.Empty Or sHB = String.Empty Or _
sRT = String.Empty Or sRB = String.Empty Or sDF = String.Empty Then
MsgBox("Select all files!" & vbCr & _
"Header: Top and Bottom," & vbCr & _
"Report: Top and Bottom," & vbCr & _
"Destination file!", MsgBoxStyle.Information, "Information...")
Exit Try
End If
'change size of array
ReDim Preserve sFiles(5)
sFiles(0) = sHT
sFiles(1) = sHB
sFiles(2) = sRT
sFiles(3) = sRB
sFiles(4) = sTF
sFiles(5) = sDF
'compare names of files
For i = sFiles.GetLowerBound(0) To sFiles.GetUpperBound(0) - 1
For j = i + 1 To sFiles.GetUpperBound(0)
If sFiles(i).ToString = sFiles(j).ToString Then
MsgBox("'" & sFiles(i).ToString & "'" & vbCr & _
" is equal to: " & vbCr & _
"'" & sFiles(j).ToString & "'" & vbCr & vbCr & _
"Can't merge the same files!", MsgBoxStyle.Information, "Information")
Exit Try
End If
Next
Next
'create instance of Excel application
oExc = CreateObject("Excel.Application")
'open template file (destination)
oWbkDst = oExc.Workbooks.Open(sTF)
'save as DestinationFileName...
'Excel will prompt user if file already exists!
oWbkDst.SaveAs(sDF)
'set destination sheet
oWshDst = oWbkDst.Worksheets(1) 'or oWbkDst.Worksheets("Name")
'----------------------- HEADER TOP -------------------------
'open source file
oWbkSrc = oExc.Workbooks.Open(sHT)
'set source sheet
oWshSrc = oWbkSrc.Worksheets(1)
'copy data
For i = 1 To 12
j = i + 1
oWshSrc.Range("B" & i.ToString).Copy(oWshDst.Range("B" & j.ToString))
Next
oWbkSrc.Close(False) 'close without saving changes
'----------------------- HEADER BOTTOM -------------------------
oWbkSrc = oExc.Workbooks.Open(sHB)
'set source sheet
oWshSrc = oWbkSrc.Worksheets(1)
'copy data
For i = 1 To 12
j = i + 1
oWshSrc.Range("B" & i.ToString).Copy(oWshDst.Range("C" & j.ToString))
Next
oWbkSrc.Close(False)
'----------------------- REPORT TOP -------------------------
oWbkSrc = oExc.Workbooks.Open(sRT)
oWshSrc = oWbkSrc.Worksheets(1)
i = 2
'start copying data from row no. 16 in continous way (step by 1, not 2)
Do
j = i + 14
oWshSrc.Range("A" & i.ToString & ":I" & i.ToString).Copy(oWshDst.Range("A" & j.ToString))
'check the line below if you don't want to add comments
oWshDst.Range("K" & j.ToString).Value = 1 'add comment (1 - report top)
i = i + 1
Loop While oWshSrc.Range("A" & i.ToString).Value <> String.Empty
oWbkSrc.Close(False)
'----------------------- REPORT BOTTOM -------------------------
oWbkSrc = oExc.Workbooks.Open(sRB)
oWshSrc = oWbkSrc.Worksheets(1)
i = 2
'continue copying; if the last row in report-top is 60, start from 61
Do
j = j + 1
oWshSrc.Range("A" & i.ToString & ":I" & i.ToString).Copy(oWshDst.Range("A" & j.ToString))
'check the line below if you don't want to add comments
oWshDst.Range("K" & j.ToString).Value = 2 'add comment (2 - report bottom)
i = i + 1
Loop While oWshSrc.Range("A" & i.ToString).Value <> String.Empty
oWbkSrc.Close(False)
'autofit columns
oWshDst.Columns("A:K").EntireColumn.AutoFit()
'save before sorting
oWbkDst.Save()
'sort data by Location and PartNumber
'first select range of cells
oWshDst.Range("A15:K" & j.ToString).Select()
oWshDst.Range("A15:K" & j.ToString).Sort(Key1:=oWshDst.Range("A16"), Order1:=1, Key2:=oWshDst.Range("B16"), Order2:=1, _
Header:=1, OrderCustom:=1, MatchCase:=False, Orientation:=1, DataOption1:=0, DataOption2:=0)
'add borders
oWshDst.Range("A15:K" & j.ToString).Borders.LineStyle = 1
'add color for headers = yellow
oWshDst.Range("A15:K15").Interior.ColorIndex = 6
'get total qty for each PartNumber => MAX(I16:I17)
i = 16
Do
j = i + 1
oWshDst.Range("J" & i.ToString & ":J" & j.ToString).Merge()
'get total qty
oWshDst.Range("J" & i.ToString & ":J" & j.ToString).Formula = "=MAX(" & oWshDst.Range("I" & i.ToString & ":I" & j.ToString).Address & ")"
'copy value of total qty
oWshDst.Range("J" & i.ToString & ":J" & j.ToString).Copy()
'paste value
oWshDst.Range("J" & i.ToString & ":J" & j.ToString).PasteSpecial(Paste:=-4163)
i = i + 2
Loop While oWshDst.Range("A" & i.ToString).Value <> String.Empty
'save
oWbkDst.Save()
Catch ex As Exception
MsgBox(ex.Message, MsgBoxStyle.Exclamation, "Error...")
retVal = 1
Finally
sFiles = Nothing
oWshSrc = Nothing
oWshDst = Nothing
oWbkSrc = Nothing
oWbkDst = Nothing
If Not oExc Is Nothing Then oExc.Visible = True
oExc = Nothing
End Try
Return retVal
End Function
Protected Overrides Sub Finalize()
MyBase.Finalize()
End Sub
End Class
现在，您需要更改表单的代码(在我的示例中为:MainFrm):
Now, you need to change code for your form (in my example: MainFrm):
Public Class MainFrm
Dim oCombMerge As ICombMerge = New TCombMerge()
Private Sub MainFrm_FormClosing(ByVal sender As Object, ByVal e As System.Windows.Forms.FormClosingEventArgs) Handles Me.FormClosing
oCombMerge = Nothing
End Sub
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
With Me
.LblHT.Text = "(select file...)"
.LblHB.Text = "(select file...)"
.LblRT.Text = "(select file...)"
.LblRB.Text = "(select file...)"
.LblDstFile.Text = oCombMerge.DestFile
.LblTF.Text = "Template: " & oCombMerge.TemplateFile
.CmdHT.Text = "Top"
.CmdHB.Text = "Bottom"
.CmdRT.Text = "Top"
.CmdRB.Text = "Bottom"
.CmdDstFile.Text = "Save in..."
.CmdMerge.Text = "Merge"
End With
End Sub
Private Sub CmdHT_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles CmdHT.Click
oCombMerge.HeaderTop = oCombMerge.GetMyFileName("Select top for header file...", Application.StartupPath)
Me.LblHT.Text = oCombMerge.HeaderTop
End Sub
Private Sub CmdHB_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles CmdHB.Click
oCombMerge.HeaderBottom = oCombMerge.GetMyFileName("Select bottom for header file...", Application.StartupPath)
Me.LblHB.Text = oCombMerge.HeaderBottom
End Sub
Private Sub CmdRT_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles CmdRT.Click
oCombMerge.ReportTop = oCombMerge.GetMyFileName("Select top for report file...", Application.StartupPath)
Me.LblRT.Text = oCombMerge.ReportTop
End Sub
Private Sub CmdRB_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles CmdRB.Click
oCombMerge.ReportBottom = oCombMerge.GetMyFileName("Select bottom for report file...", Application.StartupPath)
Me.LblRB.Text = oCombMerge.ReportBottom
End Sub
Private Sub CmdMerge_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles CmdMerge.Click
oCombMerge.MergeFiles()
End Sub
Private Sub CmdDstFile_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles CmdDstFile.Click
oCombMerge.DestFile = oCombMerge.SaveAsFileName("Save into...", Application.StartupPath & "\Output\")
Me.LblDstFile.Text = oCombMerge.DestFile
End Sub
End Class
这是 old 源代码 ^ .编译没有错误.尚未在文件上进行测试.
Here is the old source code^. Compiled without errors. Not tested on the files.
这篇关于你认为你能简化我的代码吗的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！