I made a code to carry data from one workbook to another and although that works I'm stuck on the next step. For the next step I need the data to go into a separate worksheet in the opened workbook but it would go into a different column based on the data entered into a specific cell.
Dim wb As Workbook, NR As Long
Set copySheet = Worksheets("AUForm")
Set wb = Workbooks.Open("C:\QA\Ryan\Holds_Test\AUDatabase.xlsm")
NR = Sheets("Database").Range("A" & Rows.Count).End(xlUp).Row + 1
Set pasteSheet = Worksheets("QCR")
With ThisWorkbook.Sheets("AUForm")
wb.Sheets("Database").Range("A" & NR).Value = .Range("F21").Value
wb.Sheets("Database").Range("B" & NR).Value = .Range("F11").Value
wb.Sheets("Database").Range("C" & NR).Value = .Range("F12").Value
wb.Sheets("Database").Range("D" & NR).Value = .Range("F13").Value
wb.Sheets("Database").Range("E" & NR).Value = .Range("F14").Value
wb.Sheets("Database").Range("F" & NR).Value = .Range("F15").Value
wb.Sheets("Database").Range("G" & NR).Value = .Range("F16").Value
wb.Sheets("Database").Range("H" & NR).Value = .Range("F17").Value
wb.Sheets("Database").Range("I" & NR).Value = .Range("F18").Value
wb.Sheets("Database").Range("J" & NR).Value = .Range("F19").Value
wb.Sheets("Database").Range("K" & NR).Value = .Range("F20").Value
If ThisWorkbook.Sheets("AUForm").Range("F6") = "AU1" Then
wb.Sheets("QCR").Range("A" & NR).Value = .Range("F21").Value
ElseIf ThisWorkbook.Sheets("AUForm").Range("F6") = "AU2" Then
wb.Sheets("QCR").Range("B" & NR).Value = .Range("F21").Value
ElseIf ThisWorkbook.Sheets("AUForm").Range("F6") = "AU3" Then
wb.Sheets("QCR").Range("C" & NR).Value = .Range("F21").Value
End If
End With
wb.Close savechanges:=True
Rows("21").EntireRow.Hidden = False
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
The first part works and it pastes the data into the other workbook as intended, but I'm stumped at the second half and what I could do to have the data paste into the specific columns on the separate worksheet.
I’m trying to go down a schedule and pull information from the corresponding workbooks, each row would represent a pre-defined workbook. I would prefer this to be within VBA, since I don’t like the external workbook links (i.e., indirect, index, etc), not too mention this will be 500+ lines down.
I have the file path designated in another worksheet, I have a hyperlink to each file in column B of this sheet. When I run the macro it’s currently getting hung up on me setting Name. I’m not sure what to try next. I have posted the code I have so far. Please help!
Option Explicit
Sub Pull_Data()
With Application
.Calculation = xlCalculationManual
.DisplayAlerts = False
.ScreenUpdating = False
End With
Dim wb As Workbook
Dim msh As Worksheet
Dim dsh As Worksheet
Dim i As Integer
Dim MyFile As String
Dim Name As String
Set msh = ThisWorkbook.Sheets("Master")
Dim MyPath As String: MyPath = ThisWorkbook.Sheets("Inputs").Range("M3")
MyFile = Dir(MyPath & "/*.xlsx")
For i = 7 To msh.Range("B" & Application.Rows.count).End(xlUp).row
Do While MyFile <> "" And MyFile <> ThisWorkbook.Name
If MyFile = msh.Range("B" & i).Value & ".xlsx" Then
Set wb = Workbooks.Open(MyPath & "/" & MyFile)
Set dsh = wb.Worksheets("Blank")
msh.Range("D" & i).Value = dsh.Range("M80").Value
msh.Range("E" & i).Value = dsh.Range("N80").Value
msh.Range("F" & i).Value = dsh.Range("O80").Value
msh.Range("G" & i).Value = dsh.Range("P80").Value
msh.Range("H" & i).Value = dsh.Range("Q80").Value
msh.Range("I" & i).Value = dsh.Range("R80").Value
msh.Range("J" & i).Value = dsh.Range("S80").Value
msh.Range("K" & i).Value = dsh.Range("T80").Value
wb.Close SaveChanges:=False
End If
MyFile = Dir()
Loop
Next i
MsgBox "Done"
With Application
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
After incorporating the comments from FunThomas, here is the final code that works:
Option Explicit
Sub Pull_Data()
With Application
.Calculation = xlCalculationManual
.DisplayAlerts = False
.ScreenUpdating = False
End With
Dim wb As Workbook
Dim msh As Worksheet
Dim dsh As Worksheet
Dim i As Integer
Set msh = ThisWorkbook.Sheets("Master")
Dim MyPath As String: MyPath = ThisWorkbook.Sheets("Inputs").Range("M3")
For i = 7 To msh.Range("B" & Application.Rows.count).End(xlUp).row
If Dir(MyPath & "\" & msh.Range("B" & i).Value & ".xlsx") <> "" Then
Set wb = Workbooks.Open(MyPath & "\" & msh.Range("B" & i).Value & ".xlsx")
Set dsh = wb.Worksheets("Blank")
msh.Range("D" & i).Value = dsh.Range("M80").Value
msh.Range("E" & i).Value = dsh.Range("N80").Value
msh.Range("F" & i).Value = dsh.Range("O80").Value
msh.Range("G" & i).Value = dsh.Range("P80").Value
msh.Range("H" & i).Value = dsh.Range("Q80").Value
msh.Range("I" & i).Value = dsh.Range("R80").Value
msh.Range("J" & i).Value = dsh.Range("S80").Value
msh.Range("K" & i).Value = dsh.Range("T80").Value
wb.Close SaveChanges:=False
End If
Next i
MsgBox "Done"
With Application
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
I have a code stated below in which i am saving sheet wise file in prn
i do not want to give name to the file when it save ,i just want to save my each sheet by its original name (so , the the sheet name raj,taj,bazz. they all save by its original name.
Sub CONVERT()
Dim vcounter As Long
Dim ws As Worksheet
For Each ws In Sheets
ws.Activate
vcounter = 2
While Range("A" & vcounter).Value <> ""
Range("a" & vcounter).Value = Range("a" & vcounter).Value + 1
vcounter = vcounter + 1
Wend
Application.DisplayAlerts = False
ActiveSheet.SaveAs Filename:="D:\birla soft\apache.prn"
Next ws
End Sub
This code is tested and it save a file with the ActiveSheet name and with the same extension:
ActiveSheet.SaveAs Filename:="D:\birla soft\" & ActiveSheet.Name
If you need to save it with another extension, use this code instead:
ActiveSheet.SaveAs Filename:="D:\birla soft\" & ActiveSheet.Name & ".prn"
In your code, if you need to save each sheet with its name, just change ActiveSheet with your ws variable, like this:
Sub CONVERT()
Dim vcounter As Long
Dim ws As Worksheet
For Each ws In Sheets
ws.Activate
vcounter = 2
While Range("A" & vcounter).Value <> ""
Range("a" & vcounter).Value = Range("a" & vcounter).Value + 1
vcounter = vcounter + 1
Wend
Application.DisplayAlerts = False
ws.SaveAs Filename:="D:\birla soft\" & ws.Name & ".prn"
Next ws
End Sub
I have a large report that I have to parse through and send emails to individuals based on the data in the report. I have created a macro that allows me to split the data I need into separate sheets within the workbook so that the sheet's are named based on who the data should be emailed to.
I am struggling with finding how to automate the next step so that, based on the title of the sheet (name of person not email address), an email is sent to that person.
Currently my workaround is another macro that saves all the different sheets as separate workbooks, but that still requires me to manually send emails with attachments. Perhaps there is an easier way to automate once I have all the sheets saved as separate files?
Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 5
Set ws = sheets("Master")
lr = ws.Cells(ws.rows.count, vcol).End(xlUp).row
title = "A1:W1"
titlerow = ws.Range(title).Cells(1).row
icol = ws.Columns.count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" _
And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.rows.count, icol).End(xlUp).offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
sheets.Add(after:=Worksheets(Worksheets.count)).name = myarr(i) & ""
Else
sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.copy sheets(myarr(i) & "").Range("A1")
sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub
Sub Splitbook()
'Split worksheets into seperate saved files'
Dim xPath As String
xPath = ActiveWorkbook.path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.sheets
xWs.copy
ActiveWorkbook.SaveAs filename:=xPath & "\" & xWs.name & ".xlsx"
ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Any assistance is much appreciated. Thanks in advance!
I have a macro that needs to open a few excel files and copy data from those files and paste them into the macro file in a sheet named "Consolidated".
The macro goes to a specified path, counts the number of files in the folder and then loops through to open a file, copy the contents and then save and close the file.
The macro runs perfectly on my system but not on the users systems.
The error i am receiving during the looping process is "Runtime Error '9' Subscript out of range". The line on which this error pops up is
Set wb = Workbooks.Open(Filename:=.FoundFiles(file_count))
At first i thought that the files might be opening slower than the code execution so i added wait time of 5 seconds before and after the above line...but to no avail.
The code is listed below
Sub grab_data()
Application.ScreenUpdating = False
Dim rng As Range
srow = ThisWorkbook.Sheets("Consolidated Data").Cells(65536, 11).End(xlUp).Row
'Number of filled rows in column A of control Sheet
ThisWorkbook.Sheets("Control Sheet").Activate
rawfilepth = Sheets("Control Sheet").Cells(65536, 1).End(xlUp).Row
'Loop to find the number of excel files in the path in each row of the Control Sheet
For folder_count = 2 To rawfilepth
wkbpth = Sheets("Control Sheet").Cells(folder_count, 1).Value
With Application.FileSearch
.LookIn = wkbpth
.FileType = msoFileTypeExcelWorkbooks
.Execute
filecnt = .FoundFiles.Count
'Loop to count the number of sheets in each file
For file_count = 1 To filecnt
Application.Wait (Now + TimeValue("0:00:05"))
Set wb = Workbooks.Open(Filename:=.FoundFiles(file_count))
Application.Wait (Now + TimeValue("0:00:05"))
filenm = ActiveWorkbook.Name
For sheet_count = 1 To Workbooks(filenm).Sheets.Count
If Workbooks(filenm).Sheets(sheet_count).Name <> "Rejected" Then
Workbooks(filenm).Sheets(sheet_count).Activate
ActiveSheet.Columns("a:at").Select
Selection.EntireColumn.Hidden = False
shtnm = Trim(ActiveSheet.Name)
lrow = ActiveSheet.Cells(65536, 11).End(xlUp).Row
If lrow = 1 Then lrow = 2
For blank_row_count = 2 To lrow
If ActiveSheet.Cells(blank_row_count, 39).Value = "" Then
srow = ActiveSheet.Cells(blank_row_count, 39).Row
Exit For
End If
Next blank_row_count
For uid = srow To lrow
ActiveSheet.Cells(uid, 40).Value = ActiveSheet.Name & uid
Next uid
ActiveSheet.Range("a" & srow & ":at" & lrow).Copy
ThisWorkbook.Sheets("Consolidated Data").Activate
alrow = ThisWorkbook.Sheets("Consolidated Data").Cells(65536, 11).End(xlUp).Row
ThisWorkbook.Sheets("Consolidated Data").Range("a" & alrow + 1).Activate
ActiveCell.PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Consolidated Data").Range("z" & alrow + 1).Value = shtnm
ThisWorkbook.Sheets("Consolidated Data").Range("z" & alrow + 1 & ":z" & (alrow+lrow)).Select
Selection.FillDown
ThisWorkbook.Sheets("Consolidated Data").Range("ap" & alrow + 1).Value = wkbpth
ThisWorkbook.Sheets("Consolidated Data").Range("ap" & alrow + 1 & ":ap" & (alrow + lrow)).Select
Selection.FillDown
ThisWorkbook.Sheets("Consolidated Data").Range("ao" & alrow + 1).Value = filenm
ThisWorkbook.Sheets("Consolidated Data").Range("ao" & alrow + 1 & ":ao" & (alrow + lrow)).Select
Selection.FillDown
Workbooks(filenm).Sheets(sheet_count).Activate
ActiveSheet.Range("am" & srow & ":am" & lrow).Value = "Picked"
ActiveSheet.Columns("b:c").EntireColumn.Hidden = True
ActiveSheet.Columns("f:f").EntireColumn.Hidden = True
ActiveSheet.Columns("h:i").EntireColumn.Hidden = True
ActiveSheet.Columns("v:z").EntireColumn.Hidden = True
ActiveSheet.Columns("aa:ac").EntireColumn.Hidden = True
ActiveSheet.Columns("ae:ak").EntireColumn.Hidden = True
End If
Next sheet_count
Workbooks(filenm).Close True
Next file_count
End With
Next folder_count
Application.ScreenUpdating = True
End Sub
Thanks in advance for your help.
First off, make sure you have
Option Explicit
at the top of your code so you can make sure you don't mess any of your variables up. This way, everything is dimensioned at the beginning of your procedure. Also, use variables for your workbooks, it'll clean up the code and make it more understandable, also, use indenting.
This worked for me, I found that I need to make sure the file isn't already open (assuming you aren't using an add-in) so you don't want to open the workbook with the code in it when it is already open):
Sub grab_data()
Dim wb As Workbook, wbMacro As Workbook
Dim filecnt As Integer, file_count As Integer
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wbMacro = ThisWorkbook
With Application.FileSearch
.LookIn = wbMacro.Path
.FileType = msoFileTypeExcelWorkbooks
.Execute
filecnt = .FoundFiles.Count
'Loop to count the number of sheets in each file
For file_count = 1 To filecnt
If wbMacro.FullName <> .FoundFiles(file_count) Then
Set wb = Workbooks.Open(Filename:=.FoundFiles(file_count))
Debug.Print wb.Name
wb.Close True
End If
Next file_count
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Hope that helps.
Try this (hope I didn't mess any of it up), basically, I'm checking to make sure the directory exists also, and I cleaned up the code quite a bit to make it more understandable (mainly for myself):
Sub grab_data()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim i As Long
Dim lRow As Long, lRowEnd As Long, lFolder As Long, lFilesTotal As Long, lFile As Long
Dim lUID As Long
Dim rng As Range
Dim sWkbPath As String
Dim wkb As Workbook, wkbTarget As Workbook
Dim wksConsolidated As Worksheet, wks As Worksheet
Dim v1 As Variant
Set wkb = ThisWorkbook
Set wksConsolidated = wkb.Sheets("Consolidated Data")
'Loop to find the number of excel files in the path in each row of the Control Sheet
For lFolder = 2 To wksConsolidated.Cells(65536, 1).End(xlUp).Row
sWkbPath = wksConsolidated.Cells(lFolder, 1).Value
'Check if file exists
If Not Dir(sWkbPath, vbDirectory) = vbNullString Then
With Application.FileSearch
.LookIn = sWkbPath
.FileType = msoFileTypeExcelWorkbooks
.Execute
lFilesTotal = .FoundFiles.Count
'Loop to count the number of sheets in each file
For lFile = 1 To lFilesTotal
If .FoundFiles(lFile) <> wkb.FullName Then
Set wkbTarget = Workbooks.Open(Filename:=.FoundFiles(lFile))
For Each wks In wkbTarget.Worksheets
If wks.Name <> "Rejected" Then
wks.Columns("a:at").EntireColumn.Hidden = False
lRowEnd = Application.Max(ActiveSheet.Cells(65536, 11).End(xlUp).Row, 2)
v1 = Application.Transpose(wks.Range(Cells(2, 39), Cells(lRowEnd, 39)))
For i = 1 To UBound(v1)
If Len(v1(i)) = 0 Then
lRow = i + 1
Exit For
End If
Next i
v1 = Application.Transpose(wks.Range(Cells(lRow, 40), Cells(lRowEnd, 40)))
For lUID = 1 To UBound(v1)
v1(lUID) = wks.Name & lUID
Next lUID
Application.Transpose(wks.Range(Cells(lRow, 40), Cells(lRowEnd, 40))) = v1
wks.Range("a" & lRow & ":at" & lRowEnd).Copy
i = wksConsolidated.Cells(65536, 11).End(xlUp).Row
With wksConsolidated
.Range("A" & i).PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Range("z" & i + 1).Value = wks.Name
.Range("z" & i + 1 & ":z" & i + lRowEnd).FillDown
.Range("ap" & i + 1) = sWkbPath
.Range("ap" & i + 1 & ":ap" & i + lRowEnd).FillDown
.Range("ao" & i + 1) = wkbTarget.FullName
.Range("ao" & i + 1 & ":ao" & (i + lRowEnd)).FillDown
End With
With wks
.Range("am" & lRow & ":am" & lRowEnd) = "Picked"
.Columns("b:c").EntireColumn.Hidden = True
.Columns("f:f").EntireColumn.Hidden = True
.Columns("h:i").EntireColumn.Hidden = True
.Columns("v:z").EntireColumn.Hidden = True
.Columns("aa:ac").EntireColumn.Hidden = True
.Columns("ae:ak").EntireColumn.Hidden = True
End With
End If
Next wks
wkbTarget.Close True
End If
Next lFile
End With
End If
Next lFolder
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
There may be two issues here
The macro runs perfectly on my system but not on the users systems
I presume you are running this in xl2003 as Application.FileSearch was deprecated in xl2007. So you are probably best advised to use a Dir approach instead to ensure your code works on all machines. Are you users all using xl2003?
You will get a "Object doesn't support this action" error in xl2007/10
The error i am receiving during the looping process is "Runtime Error '9' Subscript out of range
Is this error occuring on your machine, or on one/all of the user machines?
Ok guys,
I have finally been able to figure out the problem.
This error is occuring because some of the files in the raw data folder are corrupted and get locked automatically. So when the macro on opening the file gets an error and stops there.
I have now made a change to the macro. It would now first check if the files are all ok to be imported. If there is a corrupt file then it would list down their names and the user will be required to manually open it and then do a "save As" and save a new version of the corrupt file and then delete it.
Once this is done then the macro does the import of the data.
I am putting down the code below for testing the corrupt files.
Sub error_tracking()
Dim srow As Long
Dim rawfilepth As Integer
Dim folder_count As Integer
Dim lrow As Long
Dim wkbpth As String
Dim alrow As Long
Dim One_File_List As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ThisWorkbook.Sheets("Control Sheet").Activate
rawfilepth = Sheets("Control Sheet").Cells(65536, 1).End(xlUp).Row
Sheets("Control Sheet").Range("E2:E100").Clear
'Loop to find the number of excel files in the path
'in each row of the Control Sheet
For folder_count = 2 To rawfilepth
wkbpth = Sheets("Control Sheet").Cells(folder_count, 1).Value
One_File_List = Dir$(wkbpth & "\*.xls")
Do While One_File_List <> ""
On Error GoTo err_trap
Workbooks.Open wkbpth & "\" & One_File_List
err_trap:
If err.Number = "1004" Then
lrow = Sheets("Control Sheet").Cells(65536, 5).End(xlUp).Row
Sheets("Control Sheet").Cells(lrow + 1, 5).Value = One_File_List
Else
Workbooks(One_File_List).Close savechanges = "No"
End If
One_File_List = Dir$
Loop
Next folder_count
If Sheets("Control Sheet").Cells(2, 5).Value = "" Then
Call grab_data
Else
MsgBox "Please check control sheet for corrupt file names.", vbCritical, "Corrupt Files Notification"
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
This may not be one of the cleanest codes around, but it gets the job done. For those who have been troubled by this problem this is one of the ways to get around this problem. For those who havae a better way of doing this please respond with your codes.
Thanks to all for helping me out!!!!