I have a macro written that takes code from one book and transfers it to another. The problem is I need to be able to run this macro on over 90 different workbooks. Do I need to write a different macro for each workbook or is there a shortcut I can use?
luke.guthrie,
Here's one way:
Sub tgr() Dim FSO As Object Dim sFile As Variant Dim wsDest As Worksheet Dim rngDest As Range Set wsDest = ActiveWorkbook.Sheets("Sheet1") Set FSO = CreateObject("Scripting.FileSystemObject") With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False If .Show = True Then Application.ScreenUpdating = False For Each sFile In FSO.getfolder(.SelectedItems(1)).Files If LCase(Mid(sFile.Name, InStrRev(sFile.Name, "."))) Like ".xls*" Then Set rngDest = wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(2) rngDest.Value = sFile.Name With Workbooks.Open(.SelectedItems(1) & "\" & sFile.Name) ''''''''''''''''''''''''''''''''' ' ' ' Copy/paste code goes here ' ' ' ''''''''''''''''''''''''''''''''' 'Example copy/paste code: .Sheets(1).Range("A1:B10").Copy rngDest.Offset(1) .Close False End With End If Next sFile Application.ScreenUpdating = True End If End With End Sub
Hope that helps,
~tigeravatar
Forum Rules: How to use code tags, mark a thread solved, and keep yourself out of trouble
Here are the workbooks
I am now having trouble with the macro. I need the following columns to go from the workbook "Test" into "FUPLOAD Template"
1. "Test" -M6 through X6 need to go into H on "FUPLOAD" (corresponding to the amount in each month)
2. L on Test - K on FUPLOAD
3. B on Test - N on FUPLOAD
4. D on test - P on FUPLOAD
5. I on test - W on FUPLOAD
6. M8 through X (last) on Test - V on FUPLOAD
7. C on test - O on FUPLOAD
I am not very good with VBA
luke.guthrie,
I think this is the code you're looking for. Make sure that all of the workbooks that you will be copying data from are closed prior to running the macro. This macro should be stored in a standard module within the FUPLOAD workbook.
Sub tgr() Dim FSO As Object Dim sFile As Variant Dim wbDest As Workbook Dim wsDest As Worksheet Dim nRow As Long Dim lRow As Long Dim r As Long, c As Long Dim arrData() As Variant Dim DataIndex As Long Set wbDest = ActiveWorkbook Set wsDest = wbDest.Sheets("Sheet1") Set FSO = CreateObject("Scripting.FileSystemObject") With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False If .Show = True Then Application.ScreenUpdating = False For Each sFile In FSO.getfolder(.SelectedItems(1)).Files If sFile.Name <> wbDest.Name _ And LCase(Mid(sFile.Name, InStrRev(sFile.Name, "."))) Like ".xls*" Then DataIndex = 0 nRow = wsDest.Cells(Rows.Count, "K").End(xlUp).Offset(1).Row With Workbooks.Open(.SelectedItems(1) & "\" & sFile.Name) lRow = .Sheets(1).Cells(Rows.Count, "L").End(xlUp).Row ReDim arrData(1 To 16, 1 To Evaluate("CountA(M8:X" & lRow & ")")) For r = 8 To lRow For c = Columns("M").Column To Columns("X").Column If Len(Trim(.Sheets(1).Cells(r, c).Value)) > 0 Then DataIndex = DataIndex + 1 arrData(1, DataIndex) = .Sheets(1).Cells(6, c).Text arrData(4, DataIndex) = .Sheets(1).Cells(r, "L").Text arrData(7, DataIndex) = .Sheets(1).Cells(r, "B").Text arrData(8, DataIndex) = .Sheets(1).Cells(r, "C").Text arrData(9, DataIndex) = .Sheets(1).Cells(r, "D").Text arrData(15, DataIndex) = .Sheets(1).Cells(r, c).Text arrData(16, DataIndex) = .Sheets(1).Cells(r, "I").Text End If Next c Next r .Close False End With If DataIndex > 0 Then wsDest.Cells(nRow, "H").Resize(UBound(arrData, 2), 16).Value = Application.Transpose(arrData) End If End If Next sFile Application.ScreenUpdating = True End If End With End Sub
This is a little confusing. here is the code I have right now. I am only missing the amounts and corresponding dates and can't figure that out. The last section of code M8:X8 isn't working.
I also don't know how to properly insert code into this. Sorry.
Sub FUPLOADFORMAT() Dim RD As Window, FTD As Window Set RD = Windows("Test.xlsx") Set FTD = Windows("FUPLOAD Template.xlsx") RD.Activate Range("C8").Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy FTD.Activate Range("O4").Select ActiveSheet.Paste RD.Activate Range("L8").Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy FTD.Activate Range("K4").Select ActiveSheet.Paste RD.Activate Range("B8").Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy FTD.Activate Range("N4").Select ActiveSheet.Paste RD.Activate Range("D8").Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy FTD.Activate Range("P4").Select ActiveSheet.Paste RD.Activate Range("I8").Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy FTD.Activate Range("W4").Select ActiveSheet.Paste RD.Activate Range("M8:X8").Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy FTD.Activate Range("V4").Select ActiveSheet.Paste Range("H4:W1503").Select Application.CutCopyMode = False With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With End Sub
Last edited by arlu1201; 05-17-2012 at 12:58 PM. Reason: Code tags.
luke.guthrie,
In the future, please wrap your code in code tags per the forum rules (link in my sig for how).
Attached is a modified version of the FUPLOAD Template workbook. It contains a button 'Import Data' that is assigned to the macro I posted earlier. Just click the button and then select the folder that contains the test file. Make sure the test file is NOT open before you run the macro.
Last edited by tigeravatar; 05-16-2012 at 04:19 PM. Reason: Had to reupload attachment
Works perfectly. My only problem is I need to open these files and upload the data one at a time. Is this possible?
luke.guthrie,
To only do 1 file at a time, the code would look like this:
Sub tgr() Dim wbDest As Workbook Dim wsDest As Worksheet Dim nRow As Long Dim lRow As Long Dim r As Long, c As Long Dim arrData() As Variant Dim DataIndex As Long Set wbDest = ActiveWorkbook Set wsDest = wbDest.Sheets("Sheet1") With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = False .Filters.Clear .Filters.Add "Excel Files", "*.xls*" If .Show = True Then Application.ScreenUpdating = False DataIndex = 0 nRow = wsDest.Cells(Rows.Count, "K").End(xlUp).Offset(1).Row With Workbooks.Open(.SelectedItems(1)) lRow = .Sheets(1).Cells(Rows.Count, "L").End(xlUp).Row ReDim arrData(1 To 16, 1 To Evaluate("CountA(M8:X" & lRow & ")")) For r = 8 To lRow For c = Columns("M").Column To Columns("X").Column If Len(Trim(.Sheets(1).Cells(r, c).Value)) > 0 Then DataIndex = DataIndex + 1 arrData(1, DataIndex) = .Sheets(1).Cells(6, c).Text arrData(4, DataIndex) = .Sheets(1).Cells(r, "L").Text arrData(7, DataIndex) = .Sheets(1).Cells(r, "B").Text arrData(8, DataIndex) = .Sheets(1).Cells(r, "C").Text arrData(9, DataIndex) = .Sheets(1).Cells(r, "D").Text arrData(15, DataIndex) = .Sheets(1).Cells(r, c).Text arrData(16, DataIndex) = .Sheets(1).Cells(r, "I").Text End If Next c Next r .Close False End With If DataIndex > 0 Then wsDest.Cells(nRow, "H").Resize(UBound(arrData, 2), 16).Value = Application.Transpose(arrData) End If Application.ScreenUpdating = True End If End With End Sub
Run-time error '9'
Subscript out of range.
The following line is highlighted.
ReDim arrData(1 To 16, 1 To Evaluate("CountA(M8:X" & lRow & ")"))
figured it out, nevermind. Thanks for your help!
The only problem is the date is being copied incorrectly.
For example,
March 1, 2013 is showing up as March 13, 2012 after the upload
Try changing them from .Text to .Value2 and then applying the date format at the end, like so:
Sub tgr() Dim wbDest As Workbook Dim wsDest As Worksheet Dim nRow As Long Dim lRow As Long Dim r As Long, c As Long Dim arrData() As Variant Dim DataIndex As Long Set wbDest = ActiveWorkbook Set wsDest = wbDest.Sheets("Sheet1") With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = False .Filters.Clear .Filters.Add "Excel Files", "*.xls*" If .Show = True Then Application.ScreenUpdating = False DataIndex = 0 nRow = wsDest.Cells(Rows.Count, "K").End(xlUp).Offset(1).Row With Workbooks.Open(.SelectedItems(1)) lRow = .Sheets(1).Cells(Rows.Count, "L").End(xlUp).Row ReDim arrData(1 To 16, 1 To Evaluate("CountA(M8:X" & lRow & ")")) For r = 8 To lRow For c = Columns("M").Column To Columns("X").Column If Len(Trim(.Sheets(1).Cells(r, c).Value)) > 0 Then DataIndex = DataIndex + 1 arrData(1, DataIndex) = .Sheets(1).Cells(6, c).Value2 arrData(4, DataIndex) = .Sheets(1).Cells(r, "L").Value2 arrData(7, DataIndex) = .Sheets(1).Cells(r, "B").Value2 arrData(8, DataIndex) = .Sheets(1).Cells(r, "C").Value2 arrData(9, DataIndex) = .Sheets(1).Cells(r, "D").Value2 arrData(15, DataIndex) = .Sheets(1).Cells(r, c).Value2 arrData(16, DataIndex) = .Sheets(1).Cells(r, "I").Value2 End If Next c Next r .Close False End With If DataIndex > 0 Then wsDest.Cells(nRow, "H").Resize(UBound(arrData, 2), 16).Value = Application.Transpose(arrData) wsDest.Range("H4", wsDest.Cells(Rows.Count, "H").End(xlUp)).NumberFormat = "mmmm d, yyyy" End If Application.ScreenUpdating = True End If End With End Sub
That still returns the wrong year. Also I should note the format I need it: 20130301 (YYYYMMDD)
You can change the numberformat to desired. It would simply be: "yyyymmdd"
When copy/paste manually, does it still return the wrong year? because .value2 should ignore date formatting and regional settings. If that is returning it wrong, I would look at the data that is being copied over. When I ran a test, it brought in the correct dates for me
If I copy and paste it the date is correct. What changes need to be made to the code?
Sorry ignore that post it is coming over incorrect
In the formula bar I am seeing the correct date but not in the cell
There are currently 1 users browsing this thread. (0 members and 1 guests)
Posting Permissions
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks