Question

我想知道是否有人可以帮我解决这个问题; 我有一张大桌子。对于F列中满足条件的所有行（必须具有值89），我想在列A，H和I中选择相应的行。然后我想获取这些行并将它们导出为csv文件，如果文件已存在，则必须覆盖该文件。例如，让我们说我的表看起来像;

F    A   B   C   H   I
89   45  4   3   6   2
43   23  4   5   4   2
89   3   6   5   65  7
22   43  6   6   2   4
89   56  9   9   35  2

因为F列中有3行符合条件，相应的列A，H和I行具有值（45,6,2），（3,65,7）和（56,35），2）我希望我导出的文件看起来像这样;

**A   H   I**
  45  6   2
  3   65  7
  56  35  2

我遇到两件事：

只能为三个所需列中的SAME行选择特定单元格。我在互联网上找到的大多数帮助只能用于选择1个特定的单元格或整个列。鉴于我不知道F列中哪些行符合条件，我无法手动选择A，H和I列中的相应单元格，因为我不知道行号。
我的导出文件不对;它要么不能覆盖（code1），要么一遍又一遍地覆盖并在运行代码时打开新的工作簿（代码2）

我一直在来回尝试，并在互联网上寻找任何可能有用的东西，但我无法让它发挥作用。截至目前，我有2个不同的代码，我一直在努力工作，但他们都没有。第一个代码是：

Private Sub CommandButton1_Click()
Dim TransferExport As Integer
Dim u As Integer  
Dim x As Integer
Dim y As Integer
Dim data As String
For i = 2 To 18288
If Sheets("Base").Cells(i, 6).Value = "89" Then
u = Sheets("Base").Cells(i, 1).Value
If Sheets("Base").Cells(i, 6).Value = "89" Then
x = Sheets("Base").Cells(i, 8).Value
If Sheets("Base").Cells(i, 6).Value = "89" Then
y = Sheets("Base").Cells(i, 9).Value
End If
End If
End If

TransferExport = FreeFile
data = data & Sheets("Base").Cells(1, 1) & u & " ; "
data = data & Sheets("Base").Cells(1, 8) & x & " ; "
data = data & Sheets("Base").Cells(1, 9) & y & " ; "
Open "C:\Users\bruger1\Documents\Uni\TransferExport.csv" For Append As 
#TransferExport
    Print #TransferExport, u, x, y
Close #TransferExport

Next
MsgBox "Your file has been exported"

End Sub

^这是我的第一个代码。请注意，我知道我的＆＃34; If-Then＆＃34;选择u，x和y，我选择的是整列，这当然不是我想要的，但是我找不到让它只选择相应行的方法。当它确实运行时，它不能完全运行，因为有太多行（18288）并且它确实设法拔出的行只是所有人说＆＃34; 0＆＃34;，也没有拉出每行中的顶行我在数据字符串中指定的列（顶行是列名）。我试着这样做;

Dim rw As Range
Set rw = Sheets("Base").Range("F:F")
For i = 2 To 18288

If rw = "89" Then
u = Sheets("Base").Cells(rw, 1).Value

但这不会奏效。这段代码的另一个问题是，如果文件已经存在，它就不会覆盖该文件而只是拒绝运行。

我尝试的第二个代码是

Private Sub CommandButton1_Click()

Dim rng As Range
Dim cell As Range
Dim data As String

Set rng = Range("F2:F18288")

For Each cell In rng
    If cell.Value = "89" Then
        Sheets("Base").Cells(cell, "A").Select
        Sheets("Base").Cells(cell, "H").Select
        Sheets("Base").Cells(cell, "I").Select
        End If

 Selection.Copy
 data = "C:\Users\bruger1\Documents\Uni\TransferExport.csv"
Workbooks.Add
ActiveSheet.Paste
ActiveWorkbook.SaveAs Filename:=data, _
FileFormat:=xlCSV, CreateBackup:=False, local:=True
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True

Next
MsgBox "Your file has been exported"

End Sub

我有几个问题;首先，当我点击命令按钮时，每次点击它都会做不同的事情吗？有时它会不断询问我是否要覆盖现有文件，还会打开一个新文档。每次我点击是，它会打开一个新文件并立即向我询问相同的事情。如果我单击否或取消它会给我一个运行时错误＆＃34; 1004＆＃34;。有时它会导出文件但是还打开一个新的工作簿，其中包含我的表中的随机值，我没有试图将其拉出来？同时实际导出的文件＆＃34; TransferExport＆＃34;只需要一个号码＆＃34; 1＆＃34;写在A1单元格中。

如上所述，我一直在尝试在互联网上找到的任何帮助，但到目前为止没有任何工作。任何帮助将不胜感激。

Answer 1

试试这个，请阅读评论并尝试了解代码中发生的一切，随时提出问题：

Private Sub CommandButton1_Click()
    Dim data As String, lastRow As Long, i As Long
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Set wk = ThisWorkbook
    'New Workbook
    Workbooks.Add
    Set awk = ActiveWorkbook
    'Copy all data to new Workbook
    wk.Sheets("Base").Columns("A:F").Copy
    awk.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    'Find the lastRow in this data based on Column F (6)
    lastRow = awk.Worksheets(1).Cells(Excel.Rows.Count, 6).End(Excel.xlUp).Row
    'Loop and Remove any Row where F is NOT "89"
    For i = lastRow To 1 Step -1
        If awk.Worksheets(1).Cells(i, 6).Value <> "89" Then
            awk.Worksheets(1).Cells(i, 6).EntireRow.Delete
        End If
    Next
    'Delete columns we dont want
    awk.Worksheets(1).Columns("B:G").Delete Shift:=xlToLeft
    'Save/Ovewrite It, Close it.
    data = "C:\Users\bruger1\Documents\Uni\TransferExport.csv"
    awk.SaveAs Filename:=data, FileFormat:=xlCSV, AccessMode:=xlExclusive, _
        ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
    Application.Calculation = xlCalculationAutomatic
    awk.Close
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Your file has been exported"
End Sub

Answer 2

这就是你要找的东西：

Sub tgr()

    'Declare variables
    Dim wb As Workbook
    Dim wsData As Worksheet
    Dim wsTemp As Worksheet
    Dim sCSVPath As String
    Dim sCSVName As String
    Dim sSearchCol As String
    Dim vCriteria As Variant

    'Turn off these items to run code faster, prevent "screen flickering", and ignore warnings (such as if you want to override an existing file)
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With

    'Set variables
    Set wb = ActiveWorkbook
    Set wsData = wb.Sheets("Base")                                  'This is the sheet containing the original data
    Set wsTemp = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
    sCSVPath = Environ("UserProfile") & "\Documents\Uni\"           'This is the folder path where the CSV file will be stored (automatically gets logged in user's username)
    sCSVName = "TransferExport.csv"                                 'Name of the CSV file
    sSearchCol = "F"                                                'Column in the original data to search
    vCriteria = 89                                                  'Critiera to search for in the specified column

    'Work with the specified column
    With wsData.Range(wsData.Cells(1, sSearchCol), wsData.Cells(wsData.Rows.Count, sSearchCol).End(xlUp))
        'Filter for the specified criteria
        .AutoFilter 1, vCriteria

        'Copy relevant columns (A, H, and I) to the temp worksheet as values only
        Intersect(.EntireRow, .Parent.Range("A:A,H:I")).Copy
        wsTemp.Range("A1").PasteSpecial xlPasteValues

        'Remove the filter
        .AutoFilter
    End With

    'Move the temp sheet to its own workbook and save it as a CSV file and close it
    'Because we turned off item DisplayAlerts, this will automatically overwrite the file if it already exists
    wsTemp.Move
    ActiveWorkbook.SaveAs sCSVPath & sCSVName, xlCSV
    ActiveWorkbook.Close False

    'Turn items back on
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With

End Sub

使用当前工作表中的特定数据导出CSV（选择正确数据的问题）

2 个答案: