将列复制到新工作簿并另存为 csv

Question

我正在尝试：

• 从一个工作簿 (data.xlsx) 复制数据（A 列和 B 列）。
• 粘贴到新工作簿中（作为值）。
• 另存为 CSV，文件名取自第三个工作簿 (URLs.xlsx) 中的 A 列。
• 流程重复，从 data.xlsx 中获取相同的数据（每次粘贴时都是随机的）并粘贴到新的 CSV - URLs.xlsx 中有 200 行，因此我们最终应该有 200 个文件。

我已经阅读了很多主题，以下是我找到的两个：

Excel VBA Copy a Range into a New Workbook
https://www.excelcampus.com/vba/copy-paste-another-workbook/

我的尝试

复制代码并替换网络上各种不同文章中的相关组件。其中一些有效，但是当我添加缺失的位时，我遇到了我不理解的错误。

Answer 1

这是一个避免在新工作簿中复制粘贴的示例：

预期输入：

Data.xlsx 范围 A1:B200 和 RANDBETWEEN() 函数：

URLs.xlsx 范围为 A1:A200，其中一些 URL 如下所示：

运行此代码（在我的机器上大约需要 1 秒，用计时器测试）：

Dim wbData As Workbook, WBurls As Workbook
Dim CSVFileDir As String, CSVVal As String
Dim A As Long, X As Long, Y As Long, Z As Long

Option Explicit

Sub Transfer2CSV()

Set wbData = Workbooks("data.xlsx") 'Make sure it is open upon running macro
Set WBurls = Workbooks("URLs.xlsx") 'Make sure it is open upon running macro

For X = 1 To 200 'Looping through the 200 rows of WBurls
    CSVFileDir = "C:\YourDrive\" & WBurls.Sheets(1).Cells(X, 1).Value & ".csv"
    CSVVal = ""
    A = FreeFile
    Open CSVFileDir For Output As #A
    With wbData.Sheets(1).Range("A1:B200") ' or whichever range you using here
        .Calculate 'Randomize your range again
        For Y = 1 To 200 'or however many rows you have in column A and B.
            For Z = 1 To 2
                CSVVal = CSVVal & .Cells(Y, Z).Value & ","
            Next Z
            Print #A, Left(CSVVal, Len(CSVVal) - 2)
            CSVVal = ""
        Next Y
    End With
    Close #A
Next X

End Sub

输出：

每个文件看起来像：

Answer 2

这应该可行。确保您的数据和 URLS 工作簿已打开。

Sub Macro1()

Dim wsData As Worksheet, wsUrl As Worksheet, wbNew as Workbook
Dim CSVDir as String, rngU As Range

Set wsData = Workbooks("data.xlsx").Worksheets(1)
Set wsUrl = Workbooks("URLs.xlsx").Worksheets(1)
Set rngU = wsUrl.Range("A1", wsUrl.Range("A" & wsUrl.Rows.Count).End(xlUp))
CSVDir = "C:\Users\thomas.mcerlean\Desktop\Work\" 'you gave this as your dir
Set wbNew = Workbooks.Add

For Each cell In rngU
    wsData.Range("A1", wsData.Range("B" & wsData.Rows.Count).End(xlUp)).Copy Destination:= wbNew.Worksheets(1).Range("A1")
    wbNew.SaveAs Filename:= CSVDir & cell.Value & ".csv", FileFormat:=xlCSV
Next cell

wbNew.Close SaveChanges:=False
End Sub