我想用另一个工作簿中的数据填充保存宏的工作簿。根据源文件的生成方式,我需要复制的数据可以位于源文件的不同列上。因此,我可能会遇到问题,因为我可能会在错误的列上获取所需的数据,或者甚至可能获取不需要的数据。因此,我认为最好查找列标题(无论报告如何生成,它们总是相同的字符串)。我可以使用Find方法搜索标题,但是如何复制每个标题下方的行?我要粘贴数据的范围始终与粘贴工作簿上的范围相同,并且始终是第一张工作表。
以下是我当前的代码:
Sub Import()
' Looks up for the Source Report file and imports its data into wkbk that holds the macro
On Error Resume Next
' Defines Source Report file variable
Dim SourceFile As Variant
' Opens the SourceFile
MsgBox ("Open the SourceFile")
SourceFile = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
If SourceFile <> False Then
Workbooks.Open Filename:=SourceFile
End If
SourceFileDir = Dir(SourceFile)
' Looks up the last row on SourceFile to copy the entire data later
With Workbooks(SourceFileDir).Worksheets(1)
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
' MsgBox ("The last row of data in the Source File is " & LastRow)
' Sets echo off before copying
Application.ScreenUpdating = False
' Copies SourceFile data into paste file, the one that holds the macro
' Serial Number
Workbooks(SourceFileDir).Worksheets(1).Range("E7:E" & LastRow).Copy
ThisWorkbook.Worksheets(1).Range("A38").PasteSpecial xlPasteValues
' Product ID
Workbooks(SourceFileDir).Worksheets(1).Range("A7:A" & LastRow).Copy
ThisWorkbook.Worksheets(1).Range("B38").PasteSpecial xlPasteValues
' Gets out of copy mode
Application.CutCopyMode = False
' Sets echo back on
Application.ScreenUpdating = True
End Sub
我需要的总列数为9,上面的代码仅显示了其中两个,即序列号和产品ID。
感谢您的帮助。
答案 0 :(得分:0)
调整“常量”部分和“标题”数组中下方的值。
Option Explicit
Sub Import()
' Looks up for the Source Report file and imports its data into
' wkbk that holds the macro
Const LastRowColumnS As Long = 1
Const FirstRowS = 7
Const FirstRowP = 38
Dim Headers As Variant
Headers = Array("Serial Number", "Product ID", "ID", _
"Name4", "Name5", "Name6", _
"Name7", "Name8", "Name9")
Dim rng As Range
Dim SourceFile As Variant
Dim wsS As Worksheet
Dim wsP As Worksheet
Dim LastRowS As Long
Dim CurColS As Long
Dim CurColP As Long
Dim NumberOfRows As Long
Dim Count As Long
Dim i As Long
' Opens Source File.
MsgBox ("Open the SourceFile")
SourceFile = Application.GetOpenFilename( _
FileFilter:="Excel Files,*.xl*;*.xm*")
If SourceFile <> False Then
Workbooks.Open Filename:=SourceFile
Else
MsgBox "You selected cancel."
Exit Sub
End If
' Define worksheets.
Set wsS = ActiveWorkbook.Worksheets(1)
Set wsP = ThisWorkbook.Worksheets(1)
' Define last cell with data in Last Row Column of Source Sheet.
Set rng = wsS.Columns(LastRowColumnS).Find( _
What:="*", LookIn:=xlFormulas, SearchDirection:=xlPrevious)
If rng Is Nothing Then
MsgBox "No data in column."
Exit Sub
End If
NumberOfRows = rng.Row - FirstRowS + 1
For i = 0 To UBound(Headers)
' Define column of Current Header in Source Sheet.
Set rng = wsS.Cells.Find(What:=Headers(i), _
After:=wsS.Cells(wsS.Rows.Count, wsS.Columns.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rng Is Nothing Then
CurColS = rng.Column
' Define column of Current Header in Paste Sheet.
Set rng = wsP.Cells.Find(What:=Headers(i), _
After:=wsP.Cells(wsP.Rows.Count, wsP.Columns.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rng Is Nothing Then
CurColP = rng.Column
' Write data from Source Sheet to Paste Sheet.
wsP.Cells(FirstRowP, CurColP).Resize(NumberOfRows).Value _
= wsS.Cells(FirstRowS, CurColS).Resize(NumberOfRows).Value
' Count the transfer.
Count = Count + 1
End If
End If
Next i
' Maybe close Source Workbook.
'wsS.Parent.Close False
MsgBox "Transferred data from '" & Count & "' columns."
End Sub
编辑:
由于某些标题在每张纸上具有不同的值(名称),因此您应该使用两个数组(每张纸一个)并适当地调整值:
Option Explicit
Sub Import()
' Looks up for the Source Report file and imports its data into
' wkbk that holds the macro
Const LastRowColumnS As Long = 1
Const FirstRowS = 7
Const FirstRowP = 38
Dim HeadSource As Variant
Dim HeadPaste As Variant
HeadSource = Array("Serial Number", "Product ID", "ID", _
"Name4", "Name5", "Name6", _
"Name7", "Name8", "Name9")
HeadPaste = Array("Serial Number", "Product ID", "ID", _
"Name4", "Name5", "Name6", _
"Name7", "Name8", "Name9")
Dim rng As Range
Dim SourceFile As Variant
Dim wsS As Worksheet
Dim wsP As Worksheet
Dim LastRowS As Long
Dim CurColS As Long
Dim CurColP As Long
Dim NumberOfRows As Long
Dim Count As Long
Dim i As Long
' Opens Source File.
MsgBox ("Open the SourceFile")
SourceFile = Application.GetOpenFilename( _
FileFilter:="Excel Files,*.xl*;*.xm*")
If SourceFile <> False Then
Workbooks.Open Filename:=SourceFile
Else
MsgBox "You selected cancel."
Exit Sub
End If
' Define worksheets.
Set wsS = ActiveWorkbook.Worksheets(1)
Set wsP = ThisWorkbook.Worksheets(1)
' Define last cell with data in Last Row Column of Source Sheet.
Set rng = wsS.Columns(LastRowColumnS).Find( _
What:="*", LookIn:=xlFormulas, SearchDirection:=xlPrevious)
If rng Is Nothing Then
MsgBox "No data in column."
Exit Sub
End If
NumberOfRows = rng.Row - FirstRowS + 1
For i = 0 To UBound(HeadSource)
' Define column of Current Header in Source Sheet.
Set rng = wsS.Cells.Find(What:=HeadSource(i), _
After:=wsS.Cells(wsS.Rows.Count, wsS.Columns.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rng Is Nothing Then
CurColS = rng.Column
' Define column of Current Header in Paste Sheet.
Set rng = wsP.Cells.Find(What:=HeadPaste(i), _
After:=wsP.Cells(wsP.Rows.Count, wsP.Columns.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rng Is Nothing Then
CurColP = rng.Column
' Write data from Source Sheet to Paste Sheet.
wsP.Cells(FirstRowP, CurColP).Resize(NumberOfRows).Value _
= wsS.Cells(FirstRowS, CurColS).Resize(NumberOfRows).Value
' Count the transfer.
Count = Count + 1
End If
End If
Next i
' Maybe close Source Workbook.
'wsS.Parent.Close False
MsgBox "Transferred data from '" & Count & "' columns."
End Sub