[英]Copy from one workbook to another with checking cells
I am trying to copy some data from one workbook to another, with checking certain cells content from 2 files.我正在尝试将一些数据从一个工作簿复制到另一个工作簿,并检查 2 个文件中的某些单元格内容。 Below is my code:
下面是我的代码:
Sub GetFileCopyData()
Dim Fname As String
Dim SrcWbk As Workbook
Dim DestWbk As Workbook
Dim miesiac() As Variant
Dim m_i, i, wiersz_nazw As Integer
Dim Msc, nazw As String
miesiac = Array(styczeń, luty, marzec, kwiecień, maj, czerwiec, lipiec, sierpień, wrzesień, październik, listopad, grudzień)
Set DestWbk = ThisWorkbook
Set SrcWbk = ActiveWorkbook
Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Select a File")
If Fname = "False" Then Exit Sub
Set SrcWbk = Workbooks.Open(Fname)
Set DestWbk = ActiveWorkbook
Msc = SrcWbk.Cells(2, 13).Text
m_i = szukaj(miesiac, Msc)
nazw = Cells(3, 4).Text
For i = 1 To 100 Step 1
If nazw Like "*" & SrcWbk.Cells(i, 24) & "*" Then
wiersz_nazw = i: Exit For
End If
Next
SrcWbk.Cells(wiersz_nazw, 2).Copy DestWbk.Cells(m_i + 7, 3)
End Sub
Function szukaj(ByRef lista As Variant, ByVal wartosc As String)
Dim found As Integer, foundi As Integer ' put only once
found = -1
For foundi = LBound(lista) To UBound(lista):
'If lista(foundi) = wartosc Then
If StrComp(lista(foundi), wartosc, vbTextCompare) = 0 Then
found = foundi: Exit For
End If
Next
szukaj = found
End Function
It gets runtime 438 error in this line:在这一行中出现运行时 438 错误:
Msc = SrcWbk.Cells(2, 13).Text
The script have to get text parameter from source workbook cell 2,13, then take number for this text from array.该脚本必须从源工作簿单元格 2,13 中获取文本参数,然后从数组中获取此文本的编号。 Then scrip has to get text parameter from destination work book cell 3,4 and search for it in source workbook.
然后脚本必须从目标工作簿单元格 3,4 获取文本参数并在源工作簿中搜索它。 Then I can copy some data.
然后我可以复制一些数据。
This covers most of the comments.这涵盖了大部分评论。 I think it should work, but you might have to check the workbook/sheet names as I wasn't entirely clear in all cases.
我认为它应该可以工作,但是您可能需要检查工作簿/工作表名称,因为在所有情况下我都不是很清楚。
And check I have the wiersz_nazw
bit correct.并检查我的
wiersz_nazw
位是否正确。
The original 438 error was caused because Cells
needs a sheet parent, not a workbook parent.最初的 438 错误是由于
Cells
需要工作表父级而不是工作簿父级而引起的。
Sub GetFileCopyData()
Dim Fname As String
Dim SrcWbk As Workbook
Dim DestWbk As Workbook
Dim miesiac() As Variant
Dim m_i As Variant, i As Long, wiersz_nazw As Variant
Dim Msc As String, nazw As String 'each one needs to be specified
miesiac = Array(styczen, luty, marzec, kwiecien, maj, czerwiec, lipiec, sierpien, wrzesien, pazdziernik, listopad, grudzien)
Set DestWbk = ThisWorkbook 'file containing code
Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Select a File")
If Fname = "False" Then Exit Sub
Set SrcWbk = Workbooks.Open(Fname)
Msc = SrcWbk.Worksheets(1).Cells(2, 13).Text
m_i = Application.Match(Msc, miesiac, 0)
If Not IsNumeric(m_i) Then m_i = -1
nazw = SrcWbk.Worksheets(1).Cells(3, 4).Text 'change workbook/sheet as necessary
wiersz_nazw = Application.Match("*" & nazw & "*", SrcWbk.Worksheets(1).Range("X1:X100"), 0)
If IsNumeric(wiersz_nazw) Then
SrcWbk.Worksheets(1).Cells(wiersz_nazw, 2).Copy DestWbk.Worksheets(1).Cells(m_i + 7, 3) 'change sheets as necessary
End If
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.