CODEWITHSUNDEEP
vbaexcel
user2198320
user2198320

Reputation: 71

Excel VBA - Create multiple files from data in multiple workbook

I'd like to run a macro to pull certain cells from a sheet then create a file with the same name, but as a csv. I'd also like to run the macro on a whole folder, as there are 650 workbooks, but they all have the same format and I know what cells I want.

This is what I have so far:

Sub converter()

  Dim oldDoc As Workbook
  Dim newDoc As Workbook

  '## Open both workbooks first:
  Set oldDoc = Workbooks.Open("C:\test.xls")
  Set newDoc = Workbooks.Open("C:\test_converted.csv")

  'Store the value in a variable:
  impDate = oldDoc.Sheets("Input").Range("D3").Value
  impTime = oldDoc.Sheets("Input").Range("B6:B101").Value
  impNB = oldDoc.Sheets("Input").Range("C6:C101").Value
  impSB = oldDoc.Sheets("Input").Range("D6:D101").Value
  impEB = oldDoc.Sheets("Input").Range("E6:E101").Value
  impWB = oldDoc.Sheets("Input").Range("F6:F101").Value
  impLoc = oldDoc.Sheets("Input").Range("D1").Value

  'Use the variable to assign a value to the other file/sheet:
  newDoc.Sheets("Sheet1").Range("A2:A97").Value = impDate
  newDoc.Sheets("Sheet1").Range("B2:B97").Value = impTime
  newDoc.Sheets("Sheet1").Range("C2:C97").Value = impNB
  newDoc.Sheets("Sheet1").Range("D2:D97").Value = impSB
  newDoc.Sheets("Sheet1").Range("E2:E97").Value = impEB
  newDoc.Sheets("Sheet1").Range("F2:F97").Value = impWB
  newDoc.Sheets("Sheet1").Range("G2:G97").Value = impLoc

  'Close oldDoc:
  oldDoc.Close

End Sub

Basically I want newDoc to pull the filename from oldDoc and save it as a csv. Then, I'd like to be able to run multiple files at once.

Upvotes: 2

Views: 1241

Answers (1)

A.S.H
A.S.H

Reputation: 29332

You conversion once both workbooks are open is working and remains the same, the following is the skeleton to convert all the files: 

Sub converter()
  Application.DisplayAlerts = False: Application.ScreenUpdating = False: Application.EnableEvents = False

  Const fPath As String = "C:\myPath\" ' <---- Your folder path here, dont forget \
  Dim oldDoc As Workbook, newDoc As Workbook, fName As String, newName As String
  fName = Dir(fPath & "*.xl*")

  Do Until Len(fName) = 0
    Set oldDoc = Workbooks.Open(fPath & fName)
    newName = fPath & Left(fName, InStrRev(fName, ".")) & "csv"
    Set newDoc = Workbooks.Add

    ''''''''''''''''''''''''''''''''''''''''
    '
    ' Your conversion code here
    '
    ''''''''''''''''''''''''''''''''''''''''

    newDoc.SaveAs newName, xlCSV
    newDoc.Close False
    oldDoc.Close False
    fName = Dir
  Loop

Cleanup:
  If Err.Number <> 0 Then MsgBox Err.Description
  Application.DisplayAlerts = True: Application.ScreenUpdating = True: Application.EnableEvents = True
End Sub

Upvotes: 2

Related Questions