Макрос VB - создание файла CSV путем копирования соответствующих данных из различных электронных таблиц

Question

Я не пишу на VB, но мне нужен сценарий, чтобы сделать некоторую работу для меня. если кто-то может помочь ... У меня есть папка 1 с файлами Excel в ней. У меня есть лист Additional1 с некоторыми дополнительными данными.

1. Мне нужен макрос, чтобы пройти через папку1, читая файлы и копируя определенные столбцы в файл CSV (может быть новый или использующий шаблон) с определенными заголовками в первой строке.
2. Затем, глядя по номеру кошки в Additional1, скопируйте некоторые дополнительные данные из определенных столбцов
3. , а затем сохраните этот новый CSV под именем, которое можно найти под конкретным заголовком в файле Excel, который мы читаем из папки 1.

вот содержимое одного из файлов из папки1

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 CSV будет содержать данные столбца 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

эпический сбой при попытке реализовать 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

Я вставил это перед "и сохранить шаблон как новый CSV с штрих-кодом в качестве имени" в редакторе кода Криса ... Помогите, пожалуйста? как мне пройти через столбец и vlookup каждого значения?

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