Excel 文件复制操作vba代码

最新推荐文章于 2021-04-19 09:09:38 发布

软件-攻城狮

最新推荐文章于 2021-04-19 09:09:38 发布

阅读量1.1k

点赞数

分类专栏： VBA

本文链接：https://blog.csdn.net/smshuxue/article/details/16852269

版权

VBA 专栏收录该内容

9 篇文章 0 订阅

订阅专栏

[vb] view plain copy

worksheet 的代码

[vb] view plain copy

Const SourceFiledConfigStart As Integer = 2
Const SourceFiledConfigEnd As Integer = 27
Const SourceFiledDefaultStart As Integer = 41
Const SourceFiledDefaultEnd As Integer = 46
Const usersheetname As String = "数据"
Const RefSheetname As String = "配置"
Public sourcefilename As String
Public sourcefilepath As String
Dim index_Col As Integer
Dim SUBPATH As Object
Dim FieldExists As Boolean
Dim TargetColumnArray() As String
Dim SourceColumnArray() As String
Private Function CopyField(index_Object As Integer, index_Source As Integer)
Dim iColumnIndex As Integer
iColumnIndex = index_Source - 1
ActiveWorkbook.Sheets(1).Range("A2").Select
Selection.Offset(0, iColumnIndex).Select
ActiveWorkbook.Sheets(1).Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ThisWorkbook.Activate
Sheets(usersheetname).Select
Sheets(usersheetname).Range("A2").Select
iColumnIndex = index_Object - 1
Selection.Offset(0, iColumnIndex).Select
ActiveSheet.Paste
End Function
'用于记录源表列名所在的列
Private Function CopyField2(index_Object As Integer, index_Source As Integer)
Dim row As Integer
Dim iRows As Integer
iRows = ActiveWorkbook.Sheets(1).Cells(1, index_Source).CurrentRegion.Rows.Count
'列拷贝
For row = 2 To iRows
ThisWorkbook.Sheets(usersheetname).Cells(row, index_Object) = ActiveWorkbook.Sheets(1).Cells(row, index_Source).Value()
Next row
End Function
Private Function IndexCol(colName As String)
Dim iColumns As Integer
Dim column As Integer
iColumns = ActiveWorkbook.Sheets(1).UsedRange.Columns.Count
For column = 1 To iColumns
If ActiveWorkbook.Sheets(1).Cells(1, column) = colName Then
index_Col = column
Exit For
End If
Next column
End Function
Private Function DataSheetClear()
'清除第二行开始的数据
Dim rowstart As Integer
Dim iColumns As Integer
rowend = Sheets(usersheetname).UsedRange.Rows.Count
rowstart = 2
If rowend < 2 Then
Exit Function
End If
Sheets(usersheetname).Range("A" & rowstart, "A" & rowend).EntireRow.Delete
End Function
Function ExcelColumnNameConvert(ByVal r)
If r Like "[A-Z]*" Then ExcelColumnNameConvert = Range(r & 1).column
If r Like "#*" And r > 0 And r <= 256 Then ExcelColumnNameConvert = Split(Cells(1, r).Address, "$")(1)
End Function
Private Function SetField(index_Object As Integer, defaultValue As Integer)
Dim iRows As Integer
Dim AString As String
Dim AString2 As String
Dim AString3 As String
Dim AStartRow As Integer
iRows = ThisWorkbook.Sheets(usersheetname).Cells(1, index_Object).CurrentRegion.Rows.Count
AString = ExcelColumnNameConvert(index_Object)
AStartRow = 2
AString2 = AString & AStartRow
AString3 = AString & iRows
AString = AString2 & ":" & AString3
ThisWorkbook.Activate
Sheets(usersheetname).Select
Sheets(usersheetname).Range(AString2).Select
ActiveCell.FormulaR1C1 = defaultValue
Selection.AutoFill Destination:=Sheets(usersheetname).Range(AString), Type:=xlFillDefault
End Function
Private Function SetField2(index_Object As Integer, defaultValue As Integer)
Dim row As Integer
Dim iRows As Integer
iRows = ThisWorkbook.Sheets(usersheetname).Cells(1, index_Object).CurrentRegion.Rows.Count
'列拷贝
For row = 2 To iRows
ThisWorkbook.Sheets(usersheetname).Cells(row, index_Object) = defaultValue
Next row
End Function
Private Function SetDefaultFieldData()
For iRow = SourceFiledDefaultStart To SourceFiledDefaultEnd
Call SetField(ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 9), ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 2))
Next
End Function
Private Function CopyFieldData()
Set SUBPATH = CreateObject("vbscript.regexp")
With SUBPATH
.Global = True
.Pattern = ".*\\"
End With
sourcefilepath = ThisWorkbook.Sheets(RefSheetname).Cells(1, 5)
soucefilename = SUBPATH.Replace(sourcefilepath, "")
FileExists = Exist(soucefilename)
If Not FileExists Then
Workbooks.Open sourcefilepath
End If
Windows(soucefilename).Activate
For iRow = SourceFiledConfigStart To SourceFiledConfigEnd
Windows(soucefilename).Activate
Call CopyField(ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 9), ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 3))
Next
End Function
Private Function GetTargetColumns()
Dim iCount As Integer
Dim strValue As String
Dim str As String
Set SUBPATH = CreateObject("vbscript.regexp")
With SUBPATH
.Global = True
.Pattern = ".*\\"
End With
ThisWorkbook.Activate
If ThisWorkbook.Sheets(RefSheetname).Cells(1, 5) = "" Then
MsgBox "没有选择Excel文件", vbOKOnly, "配置错误"
Exit Function
End If
sourcefilepath = ThisWorkbook.Sheets(RefSheetname).Cells(1, 5)
soucefilename = SUBPATH.Replace(sourcefilepath, "")
FileExists = Exist(soucefilename)
If Not FileExists Then
Workbooks.Open sourcefilepath
End If
Windows(soucefilename).Activate
iCount = ActiveWorkbook.Sheets(1).Cells(1, 1).CurrentRegion.Columns.Count
strValue = ""
str = ""
For iColumn = 1 To iCount - 1
str = Trim(ActiveWorkbook.Sheets(1).Cells(1, iColumn).Value)
strValue = strValue + str + ","
Next
strValue = strValue + Trim(ActiveWorkbook.Sheets(1).Cells(1, iCount).Value)
InitCandidateValue (strValue)
TargetColumnArray = Split(strValue, ",")
End Function
Private Sub CommandButton1_Click()
Dim FileExists As Boolean
FieldExists = Flase
'清除基站信息检测模板数据和检测报告
Call DataSheetClear
Call GetTargetColumns
'处理数据
FieldExists = CheckTargetFields
If Not FieldExists Then
MsgBox "目标文件检查失败"
Exit Sub
End If
FieldExists = CheckSourceFields
If Not FieldExists Then
MsgBox "本文件数据sheet检查失败"
Exit Sub
End If
Sheets(RefSheetname).Select
MsgBox "检查完成"
End Sub
Private Function CheckSourceFields() As Boolean
Dim iRow As Integer
Dim iFieldIndex As Integer
Dim sFieldName As String
Dim iCols As Integer
Dim iCol As Integer
Dim errFields As String
Dim errMSG As String
errMSG = ""
errFields = ""
getProjectDColumn
For iRow = SourceFiledConfigStart To SourceFiledConfigEnd
For iFieldIndex = 0 To UBound(SourceColumnArray)
sFieldName = SourceColumnArray(iFieldIndex)
If sFieldName = Trim(ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 1)) Then
ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 9) = iFieldIndex + 1
Exit For
End If
Next
If Trim(ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 9)) = "" Then
errFields = errFields & ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 1) & " "
End If
Next
For iRow = SourceFiledDefaultStart To SourceFiledDefaultEnd
For iFieldIndex = 0 To UBound(SourceColumnArray)
sFieldName = SourceColumnArray(iFieldIndex)
If sFieldName = Trim(ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 1)) Then
ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 9) = iFieldIndex + 1
Exit For
End If
Next
If Trim(ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 9)) = "" Then
errFields = errFields & ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 1) & " "
End If
Next
If errFields <> "" Then
ThisWorkbook.Activate
errMSG = "工程参数表对应列名： " & errFields & "不存在，请检查输入是否正确！"
MsgBox errMSG, vbOKOnly, "字段配置错误"
CheckSourceFields = False
Else
CheckSourceFields = True
End If
End Function
Private Sub CommandButton2_Click()
Dim filename As Variant
'打开文件对话框返回的文件名，是一个全路径文件名，其值也可能是False，因此类型为Variant
Dim sFileName As String '从FileName中提取的文件名
Dim sPathName As String '从FileName中提取的路径名
Dim aFile As Variant
Dim values As String
filename = Application.GetOpenFilename("Excel 文件,*.xls;*.xlsx")
Call DataSheetClear
'调用Windows打开文件对话框
If filename <> False Then '如果未按“取消”键
aFile = Split(filename, "\") '在全路径中，以“\”为分隔符，分成数据
sPathName = aFile(0) '取盘符
For i = 1 To UBound(aFile) - 1 '循环合成路径名
sPathName = sPathName & "\" & aFile(i)
Next
sFileName = aFile(UBound(aFile)) '数组的最后一个元素为文件名
Cells(1, 5).Value = sPathName & "\" & sFileName '保存路径名
FileExists = Exist(sFileName)
If Not FileExists Then
Workbooks.Open filename
End If
Windows(sFileName).Activate
values = getColumnValue(sFileName, filename)
InitCandidateValue (values)
ThisWorkbook.Activate
MsgBox "文件选择完成"
Else
MsgBox "文件选择失败"
Exit Sub
End If
End Sub
Private Function CheckTargetFields() As Boolean
Dim iRow As Integer
Dim iFieldIndex As Integer
Dim sFieldName As String
Dim iCols As Integer
Dim iCol As Integer
Dim errFields As String
Dim errMSG As String
errMSG = ""
errFields = ""
For iRow = SourceFiledConfigStart To SourceFiledConfigEnd
If Trim(ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 2)) = "" Then
errFields = errFields & ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 1) & " "
End If
For iFieldIndex = 0 To UBound(TargetColumnArray)
sFieldName = TargetColumnArray(iFieldIndex)
If sFieldName = Trim(ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 2)) Then
ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 3) = iFieldIndex + 1
Exit For
End If
Next
If Trim(ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 3)) = "" Then
errFields = errFields & ThisWorkbook.Sheets(RefSheetname).Cells(iRow, 1) & " "
End If
Next
If errFields <> "" Then
ThisWorkbook.Activate
errMSG = "源表对应列名： " & errFields & "不存在，请检查输入是否正确！"
MsgBox errMSG, vbOKOnly, "字段配置错误"
CheckTargetFields = False
Else
CheckTargetFields = True
End If
End Function
Private Function Exist(ByVal filename As String) As Boolean
Dim iCount As Integer
Dim i As Integer
iCount = Workbooks.Count
For i = 1 To iCount
If Workbooks.Item(i).Name = filename Then
Exist = True
Exit For
End If
Next
If i > iCount Then
Exist = False
End If
End Function
Private Function getProjectDColumn() As String
Dim strValue As String
Dim str As String
Dim iCount As Integer
Dim iColumn As Integer
'Windows(sFileName).Activate
iCount = ThisWorkbook.Sheets(usersheetname).Cells(1, 1).CurrentRegion.Columns.Count
strValue = ""
str = ""
For iColumn = 1 To iCount - 1
str = Trim(ThisWorkbook.Sheets(usersheetname).Cells(1, iColumn).Value)
strValue = strValue + str + ","
Next
str = Trim(ThisWorkbook.Sheets(usersheetname).Cells(1, iCount).Value)
strValue = strValue + str
SourceColumnArray = Split(strValue, ",")
iCount = UBound(TargetColumnArray)
getProjectDColumn = strValue
End Function
Private Function getColumnValue(ByVal sFileName As String, ByVal filename As String) As String
Dim strValue As String
Dim str As String
Dim iCount As Integer
Dim iColumn As Integer
FileExists = Exist(sFileName)
If Not FileExists Then
Workbooks.Open filename
End If
Windows(sFileName).Activate
'Windows(sFileName).Activate
iCount = ActiveWorkbook.Sheets(1).Cells(1, 1).CurrentRegion.Columns.Count
strValue = ""
str = ""
For iColumn = 1 To iCount - 1
str = Trim(ActiveWorkbook.Sheets(1).Cells(1, iColumn).Value)
strValue = strValue + str + ","
Next
str = Trim(ActiveWorkbook.Sheets(1).Cells(1, iCount).Value)
strValue = strValue + str
TargetColumnArray = Split(strValue, ",")
iCount = UBound(TargetColumnArray)
getColumnValue = strValue
End Function
Public Function InitCandidateValue(ByVal values As String)
ThisWorkbook.Activate
Sheets(RefSheetname).Select
Range("D2:D100").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=values
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = True
End With
End Function
Private Sub CommandButton3_Click()
' 复制数据开始了
Call DataSheetClear
Call CopyFieldData
Call SetDefaultFieldData
End Sub

[vb] view plain copy

ThisWorkBook的代码

[vb] view plain copy

Const usersheetname As String = "数据"
Const RefSheetname As String = "配置"
Private Sub Workbook_Open()
If Sheets(RefSheetname).Cells(1, 5).Value = "" Then
Sheets(RefSheetname).InitCandidateValue (" ")
Sheets(RefSheetname).Range("D2:D100").ClearContents
Sheets(RefSheetname).Select
End If
End Sub

软件-攻城狮

关注

0
点赞
踩
0

收藏

觉得还不错? 一键收藏
0
评论
Excel 文件复制操作vba代码

[vb] view plaincopyworksheet 的代码 [vb] view plaincopyConst SourceFiledConfigStart As Integer = 2 Const SourceFiledConfigEnd As Integer = 27 Const SourceFiledDefaultStart As I
复制链接

扫一扫