Excel VBA：复制所需数据

Question

我需要编写一个代码，帮助将与每个唯一ID相关的所有数据复制到一个新的CSV文件中（这意味着每个唯一ID的一个CSV文件）。我是Excel VBA的新手。我可以将整个数据复制到CSV文件中。但是，我没有为每个唯一ID执行此操作。

Sub ExportContract(Control As IRibbonControl)
If ThisWorkbook.ActiveSheet.Name <> "Contract" Then
MsgBox "Please Select Contract tab and run again!"
Exit Sub
End If

Application.ScreenUpdating = False
AccountName = ThisWorkbook.Sheets("Information").Range("B4")
Path = Application.ActiveWorkbook.Path
Sheets("Contract").Select
Sheets("Contract").Copy
ActiveWorkbook.SaveAs Filename:=Path & "\" & AccountName & "_Contract.csv", 
FileFormat:=xlCSV, CreateBackup:=False
ActiveWindow.Close
End Sub

现在，这不是此剪辑的代码。但是，这是我将把您提供的解决方案纳入其中的真正计划。

Answer 1

您需要从第一个单元格开始，向下移动并导出每一行。当您导出到CSV时，可能更容易通过写入文本文件来导出它，而不是通过＆＃34; saveas＆＃34;

以下是一些可以帮助您入门的代码：

Public Sub Export()
'//Sort the data first
With ActiveWorkbook.Worksheets("Sheet1").Sort
    .SetRange Range("A2:B11")
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
'//Select the first cell
ThisWorkbook.Sheets(1).Range("A2").Select

Dim sFileName As String
Dim ID As Long
While ActiveCell.Value <> ""        '//Loop until we have gone over all cells
    '//Get the value and file name
    ID = ActiveCell.Value
    sFileName = ThisWorkbook.Path & "\" & ID & ".csv"
    Open sFileName For Output As #1
    '//Keep going until we have dealt with this id
    While ActiveCell.Value = ID
        Print #1, ActiveCell.Value & "," & ActiveCell.Offset(0, 1).Value
        ActiveCell.Offset(1, 0).Select
    Wend
    '//Close that file
    Close #1
Wend

End Sub