Question

我不写VB，但我需要一个脚本为我做一些工作。如果有人能帮忙...... 我有一个带有excel文件的folder1。我有一张附加1的表格和一些额外的数据。

我需要一个宏来通过folder1读取文件并将某些列复制到CSV文件（可以是新的或使用模板），第一行包含某些标题。
然后按附加1中的cat编号查看某些列的其他数据
然后将此新CSV保存在名称中，该名称可以在我们从folder1读取的excel文件中的特定标题下找到。

这是folder1

Aritst  Year    Manufacturer UPC    Catalog No  Track # Track Name
Blackfield  2007    8.02645E+11     KSCOPE126M  1       Once
Blackfield  2007    8.02645E+11     KSCOPE126M  2       Bla People
Blackfield  2007    8.02645E+11     KSCOPE126M  3       Miss U
Blackfield  2007    8.02645E+11     KSCOPE126M  4       Christenings

说我只需要

A，B，D和F列复制到

K，E，A和AD

相应（即CSV列A将包含已打开电子表格的D列数据 - 在上面的示例目录号中）

这是我得到的代码：

Sub Convert_to_Digi()

  ' First delete existing data
  Dim LastRow As Long
  Dim SrcWkb As Workbook
  Dim StartRow As Long
  Dim wkbname As Variant
  Dim xlsFiles As Variant
  Dim MyRange As Variant
  Dim NewName As Variant

    StartRow = 2

' Get the workbooks to open
    xlsFiles = Application.GetOpenFilename(FileFilter:="Excel files (*.xls), *.xls", MultiSelect:=True)
      If VarType(xlsFiles) = vbBoolean Then Exit Sub

     ' Loop through each workbook and copy the data to this CSV
      For Each wkbname In xlsFiles
        Set SrcWkb = Workbooks.Open(Filename:=wkbname, ReadOnly:=True)
            MyRange = Sheets("export_label_conf").Range("A:A")
            LastRow = Application.WorksheetFunction.CountA(MyRange)
            Sheets("export_label_conf").Select
            NewName = Cells(3, 2) & ".csv"

            If LastRow >= StartRow Then

                ' copy column D data
                With SrcWkb.Worksheets("export_label_conf")
                    .Range(.Range("D2"), .Range("D").LastRow).Copy

                    SrcWkb.Worksheets("export_label_conf").Select
                    Range("D2:D" & LastRow).Select
                    Selection.Copy

                    ' paste into CSV template file
                    Workbooks.Open Filename:="C:\DIGITAL\template.csv", ReadOnly:=False
                    Range("A2").Select
                    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                        :=False, Transpose:=False

                End With

                ' and save template as new CSV with barcode as name
                Name = CurDir & "\" & NewName
                ActiveWorkbook.SaveAs Filename:= _
                    Name, FileFormat:= _
                    xlCSV, CreateBackup:=False
            End If

        SrcWkb.Close
      Next wkbname

End Sub

我坚持将多个列一次复制到CSV文件中...并且通常不确定脚本是否正确写入=）有人可以帮我一把吗？

更新28.02.11 11:23

epic在尝试实现vlookup =）时失败了

'vlookup电子表格中的其他数据

    Dim FndStr As String
    Dim FndVal As Range
    Dim addWkb As Variant
    Dim AddInfo As String

    ' copy column E
    FndStr = MyRange.Columns(12).Value

    Set addWkb = Workbooks.Open(Filename:="C:\DIGITAL\Snapper Owned  Licensed Catalogue.xls", ReadOnly:=True)

    Set FndVal = Columns("B:B").Find(What:=FndStr, LookAt:=xlWhole)
       If FndVal Is Nothing Then
          MsgBox "ID not found!!"
       Else
            'get value of column D
            AddInfo = FndVal.Offset(0, 3).Value
       End If

    ' paste into CSV template file, ADDITIONAL INFO into AO column
    csvWkb.ActiveSheet.Cells(2, 41).PasteSpecial Paste:=AddInfo, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

我之前粘贴了这个，并在Chris的代码编辑中将模板保存为带有条形码作为名称的新CSV ...请帮忙吗？我如何通过列循环并查看每个值？

Answer 1

关于多列的复制，有可能（例如Range("A2:A4,B2:B4,D2:D4,F2:F4").Copy），但是当你粘贴它们时，它们将处于连续范围内 - 更好地单独复制

我重新考虑了你的代码，给你一些提示

Sub Convert_to_Digi()

    ' First delete existing data
    Dim SrcWkb As Workbook
    Dim csvWkb As Workbook
    Dim srcSheet As Worksheet
    Dim StartRow As Long
    Dim wkbname As Variant
    Dim xlsFiles As Variant
    Dim MyRange As Range
    Dim NewName As Variant
    Dim csvName As String

    StartRow = 2

    ' Get the workbooks to open
    xlsFiles = Application.GetOpenFilename(FileFilter:="Excel files (*.xls), *.xls", MultiSelect:=True)
    If VarType(xlsFiles) = vbBoolean Then Exit Sub

    ' Loop through each workbook and copy the data to this CSV
     For Each wkbname In xlsFiles
        Set SrcWkb = Workbooks.Open(Filename:=wkbname, ReadOnly:=False)
        Set srcSheet = SrcWkb.Worksheets("export_label_conf")

        ' Get used range on sheet
        Set MyRange = srcSheet.UsedRange
        ' Adjust to exclude top row
        Set MyRange = MyRange.Offset(1, 0).Resize(MyRange.Rows.Count - 1)

        NewName = srcSheet.Cells(3, 2) & ".csv"

        If MyRange.Row + MyRange.Rows.Count - 1 >= StartRow Then
            Set csvWkb = Workbooks.Open(Filename:="C:\DIGITAL\template.csv", ReadOnly:=False)

            ' copy column A
            MyRange.Columns(1).Copy
            ' paste into CSV template file, column K
            csvWkb.ActiveSheet.Cells(2, 11).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False

            ' copy column B
            MyRange.Columns(4).Copy
            ' paste into CSV template file
            csvWkb.ActiveSheet.Cells(2, 5).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False

            ' copy column D
            MyRange.Columns(4).Copy
            ' paste into CSV template file, column A
            csvWkb.ActiveSheet.Cells(2, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False

            ' copy column F
            MyRange.Columns(6).Copy
            ' paste into CSV template file, column AD
            csvWkb.ActiveSheet.Cells(2, 30).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False

            ' and save template as new CSV with barcode as name
            csvName = CurDir & "\" & NewName '  using CurDir is a bit dangerous: how do you know what its set to?
            ActiveWorkbook.SaveAs Filename:=csvName, FileFormat:=xlCSV, CreateBackup:=False
        End If

        SrcWkb.Close
    Next wkbname

End Sub

VB宏 - 通过复制来自不同电子表格的相关数据来创建CSV文件

1 个答案: