Excel VBA：复制所需的数据

Question

I need to write a code that could help copy all the data pertaining to each unique ID into a new CSV file (meaning one CSV file for each unique ID). I'm very new to Excel VBA. I am able to copy the entire data into a CSV file. However, I fail to do so for each unique 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

Now, this is not the code for this snip. But, this is the real program I will be incorporating the solution you provide, into.

Answer 1

You need to start at the first cell, move down and export each row. As you're exporting to CSV, it is probably easier to export it by writing to a text file, not via "saveas"

Here is some code to get you started:

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