数据提取

Question

编辑：感谢您的帮助之前，我已经在代码中的变化和编辑我的问题（包括如A &乙一定的参考），使得它更容易，现在理解了。

我有很多列的文件夹中的多个文件，让我们称之为一个这些文件“main.csv”。 “main”中有2列包含X和Y坐标。在所谓的“site.csv”另一个文件，我有的列表中选择所需 X和Y坐标及其网站＃ 我做了一个VBA来：

1）保持在“主”的文件，只有与“B”中的X和Y坐标相匹配的行，并且还在主文件中用“site.csv”文件（附带屏幕截图）中的名称更新了一个名为“Site”的列。

2）删除所有其余

并且如果可能的话（因为我d ONT懂得这个代码） - >文件夹中进行此VBA环通的所有文件（如“main.csv”），因为有他们的很多。参考文件是相同的 - “site.csv”

截图：

Main.csv file

Site.csv file - Reference file

到目前为止，我发现了以下错误：

运行时错误“1004”：应用程序定义或对象定义的错误（如位置VBA评语）

下面是代码：

Option Explicit 

Sub fetchdata() 

Dim x As Integer 
Dim y As Integer 
Dim finalrow As Long 
Dim i As Integer 

Dim LastRow As Long 

x = Application.Workbooks("Site.csv").Worksheets("Site").Range("A2").Value 'Stores the x-coordinate of the Site file which contains the list of required coordinates 

y = Application.Workbooks("Site.csv").Worksheets("Site").Range("B2").Value 

finalrow = Application.Workbooks("Main.csv").Worksheets("Main").Range("D70000").End(xlUp).Row 'Stores the row detail of the last row in the Main file 

For i = 7 To finalrow 
    If Application.Workbooks("Main.csv").Worksheets("Main").Range(Cells(i, 4) = x And Cells(i, 5) = y) Then 'ERROR IDENTIFIED HERE 
     Application.Workbooks("Site.csv").Worksheets("Site").Range(Cells(i - 5, 3)).Copy 
     Application.Workbooks("Main.csv").Worksheets("Main").Range("F7").PasteSpecial xlPasteFormulasAndNumberFormats 'Here I basically want to replace the existing site number with that in my reference file (site.csv) 

    Else 
     Application.Workbooks("Main.csv").Worksheets("Main").Rows(i).EntireRow.Delete 'Delete Everything else 
End If 

Next i 

End Sub 

Answer 1

嗨你的错误，在这些线路：

.Range(Cells(i, 4) I removed Range()

= y) I removed ")"

Range(Cells(i - 5, 3)) I removed Range()

下面的代码应该工作

Option Explicit 

Sub fetchdata() 

Dim x As Integer 
Dim y As Integer 
Dim finalrow As Long 
Dim i As Integer 

Dim LastRow As Long 

x = Application.Workbooks("Site.csv").Worksheets("Site").Range("A2").Value 'Stores the x-coordinate of the Site file which contains the list of required coordinates 

y = Application.Workbooks("Site.csv").Worksheets("Site").Range("B2").Value 

finalrow = Application.Workbooks("Main.csv").Worksheets("Main").Range("D70000").End(xlUp).Row 'Stores the row detail of the last row in the Main file 

For i = 7 To finalrow 
    If Application.Workbooks("Main.csv").Worksheets("Main").Cells(i, 4) = x And Cells(i, 5) = y Then 'ERROR IDENTIFIED HERE 
     Application.Workbooks("Site.csv").Worksheets("Site").Cells(i - 5, 3).Copy 
     Application.Workbooks("Main.csv").Worksheets("Main").Range("F7").PasteSpecial xlPasteFormulasAndNumberFormats 'Here I basically want to replace the existing site number with that in my reference file (site.csv) 

    Else 
     Application.Workbooks("Main.csv").Worksheets("Main").Rows(i).EntireRow.Delete 'Delete Everything else 
End If 

Next i 

End Sub 

新代码的08/12与目录循环：

Sub fetchdata() 

Dim x As Integer 
Dim y As Integer 
Dim finalrow As Long 
Dim i As Integer 
Dim site As Workbook 
Dim main As Workbook 
Dim site_sh As Worksheet 
Dim main_sh As Worksheet 
Dim LastRow As Long 
Dim finalrow_main, finalrow_site, i_site, i_main, site_val_x, site_val_y, main_val_x, main_val_y As Variant 
Dim criteria As String 
Dim delete_row As Boolean 
Dim MyObj As Object, MySource As Object, file As Variant 
Dim file_path, list_file, final_message As String 


file_path = "C:\Users\u6042371\Documents" 'Set directory for "Main" file types here 

If Right(file_path, 1) <> "\" Then file_path = file_path & "\" 

list_file = "" 'this will store a file list for later 

criteria = "main*.xls" 'this will search for all files beginning with main ending with .xls, you can use * as a wildcard, just change main 

file = Dir(file_path & criteria) 

While (file <> "") 

    Workbooks.Open Filename:=file_path & file 

    Set main = Workbooks(file) 'will auto open 
    Set site = Workbooks("Site.xlsx") 'manual open this workbook 
    Set main_sh = main.Worksheets("Main") 'name of sheet ex Main sheet in Main workbook 
    Set site_sh = site.Worksheets("Site") 'name of sheet ex Site sheet in Site workbook 

    finalrow_main = main_sh.Range("D70000").End(xlUp).Row 'gets last row of Main Sheet 
    finalrow_site = site_sh.Range("A70000").End(xlUp).Row 'gets last row of Site Sheet 
    delete_row = False 'flag if to delete row at the end of for loop 

    For i_main = finalrow_main To 7 Step -1 'to loop through all Main x, y, this looks through end to start of data, delete technique 
     main_val_x = main_sh.Cells(i_main, 4).Value 'set x value of current row of Main sheet 
     main_val_y = main_sh.Cells(i_main, 5) 'set y value of current row of Main sheet 


     For i_site = 2 To finalrow_site 'to loop through all Site x,y starts at the beginning of site 
      site_val_x = site_sh.Cells(i_site, 1) 'set x value of current row of Site sheet 
      site_val_y = site_sh.Cells(i_site, 2) 'set y value of current row of Site sheet 


      If site_val_x = main_val_x And site_val_y = main_val_y Then 'compares x,y from Site to x,y from Main 
       main_sh.Cells(i_main, 6) = site_sh.Cells(i_site, 3) 

       delete_row = False 'Set delete to false because there has been a match 
       Exit For 'Exits loop to check next site row 
      Else 
       delete_row = True 'if there are no matches this will become True 

      End If 

     Next i_site 

     If delete_row = True Then 'if delete = True then delete 
      main_sh.Rows(i_main).Delete 
     End If 



    Next i_main 

    Workbooks(file).Save 
    Workbooks(file).Close 
    list_file = list_file + file + Chr(13) 

    file = Dir 


Wend 

final_message = "The following files have been processed:" + Chr(13) + list_file 
MsgBox final_message 

End Sub 

Answer 2

我不相信在Range类中有一个名为.ClearData的方法。你的意思是ClearContents？这将清除指定单元格中的所有值。

Sub fetchdata() 
    Dim x As Integer 'Coordinates that need to be fetched 
    Dim y As Integer 
    Dim finalrow As Integer 
    Dim i As Integer 

    ActiveSheet.Range("D2:D10000").ClearContents 
    x = Sheets("Sheet2").Range("A2").Value 
    y = Sheets("Sheet2").Range("B2").Value 
    finalrow = Sheets("Book1").Range("D10000").End(xlUp).Row 

    For i = 7 To finalrow 
     If Cells(i, 4) = x And Cells(i, 5) = y Then 
      Sheets("Book1").Range(Cells(i, 1), Cells(i, 221)).Copy 
      Sheets("Sheet2").Range("D10000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats 
     End If 
    Next i 
End Sub