Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Looping & Dumping
My Objective: Loop through workbooks in a Folder, then point to "Proposals"
worksheet in each workbook, then dump entries into "Proposals05" worksheet in current workbook. The code works if Proposals in 1st wks has "2" Proposals in 2nd wks has "1" Then proposals 05: 2 1 However, if: Proposals in 1st wks has "2" and "122" Proposals in 2nd wks has "1" and "111" Then proposals 05: 2 1 111 instead of all 4 entries, my code below requires slight tweaking, any help is appreciated Sub SubGetMyData3d() Dim objFSO As Object Dim objFolder As Object Dim objFile As Object Dim owb As Workbook Dim j As Long Dim RngToCopy, Rng2ToCopy As Range Dim intNumRows As Integer, c As Range, lngCellTotal As Long Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.GetFolder("C:\My Documents\Career") j = 1: k = 1: l = 1 For Each objFile In objFolder.Files If objFile.Type = "Microsoft Excel Worksheet" Then Set owb = Workbooks.Open(Filename:=objFolder.Path _ & "\" & objFile.Name) With owb.Worksheets("Proposals") Set RngToCopy = .Range("B1:B" _ & .Cells(.Rows.Count, "B").End(xlUp).Row) End With RngToCopy.EntireRow.Copy _ Destination:=Worksheets("Proposals05").Cells(j, 1) j = Worksheets("Proposals05") _ .Cells(Rows.Count, "A").End(xlUp).Row + 1 intNumRows = Cells(50, "B").End(xlUp).Row End If Next objFile For Each c In Worksheets("Proposals05").Range("B1:B" & intNumRows) lngCellTotal = lngCellTotal + c.Value Next 'With Worksheets("Proposals05").Range("B" & intNumRows + 1) ' .Borders(xlEdgeLeft).Weight = xlMedium ' .Borders(xlEdgeTop).Weight = xlMedium ' .Value = lngCellTotal 'End With End Sub |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Looping & Dumping
Teresa,
Hopefully, this is it Option Explicit Sub SubGetMyData3d() Dim objFSO As Object Dim objFolder As Object Dim objFile As Object Dim owb As Workbook Dim j As Long Dim RngToCopy As Range, Rng2ToCopy As Range Dim intNumRows As Integer, c As Range, lngCellTotal As Long Application.ScreenUpdating = False Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.GetFolder("C:\MyTest\Proposals") j = 1 For Each objFile In objFolder.Files If objFile.Type = "Microsoft Excel Worksheet" Then Set owb = Workbooks.Open(Filename:=objFolder.Path _ & "\" & objFile.Name) With owb.Worksheets("Proposals") Set RngToCopy = .Range("B1:B" _ & .Cells(.Rows.Count, "B").End(xlUp).Row) End With RngToCopy.EntireRow.Copy _ Destination:=ThisWorkbook.Worksheets("Proposals05" ).Cells(j, 1) owb.Close savechanges:=False j = ThisWorkbook.Worksheets("Proposals05") _ .Cells(Rows.Count, "B").End(xlUp).Row + 1 intNumRows = Cells(Rows.Count, "B").End(xlUp).Row End If Next objFile With Worksheets("Proposals05").Range("B" & intNumRows + 1) .Borders(xlEdgeLeft).Weight = xlMedium .Borders(xlEdgeTop).Weight = xlMedium .Value = WorksheetFunction.Sum(Range("B1:B" & intNumRows)) End With Application.ScreenUpdating = True End Sub -- HTH RP (remove nothere from the email address if mailing direct) "teresa" wrote in message ... My Objective: Loop through workbooks in a Folder, then point to "Proposals" worksheet in each workbook, then dump entries into "Proposals05" worksheet in current workbook. The code works if Proposals in 1st wks has "2" Proposals in 2nd wks has "1" Then proposals 05: 2 1 However, if: Proposals in 1st wks has "2" and "122" Proposals in 2nd wks has "1" and "111" Then proposals 05: 2 1 111 instead of all 4 entries, my code below requires slight tweaking, any help is appreciated Sub SubGetMyData3d() Dim objFSO As Object Dim objFolder As Object Dim objFile As Object Dim owb As Workbook Dim j As Long Dim RngToCopy, Rng2ToCopy As Range Dim intNumRows As Integer, c As Range, lngCellTotal As Long Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.GetFolder("C:\My Documents\Career") j = 1: k = 1: l = 1 For Each objFile In objFolder.Files If objFile.Type = "Microsoft Excel Worksheet" Then Set owb = Workbooks.Open(Filename:=objFolder.Path _ & "\" & objFile.Name) With owb.Worksheets("Proposals") Set RngToCopy = .Range("B1:B" _ & .Cells(.Rows.Count, "B").End(xlUp).Row) End With RngToCopy.EntireRow.Copy _ Destination:=Worksheets("Proposals05").Cells(j, 1) j = Worksheets("Proposals05") _ .Cells(Rows.Count, "A").End(xlUp).Row + 1 intNumRows = Cells(50, "B").End(xlUp).Row End If Next objFile For Each c In Worksheets("Proposals05").Range("B1:B" & intNumRows) lngCellTotal = lngCellTotal + c.Value Next 'With Worksheets("Proposals05").Range("B" & intNumRows + 1) ' .Borders(xlEdgeLeft).Weight = xlMedium ' .Borders(xlEdgeTop).Weight = xlMedium ' .Value = lngCellTotal 'End With End Sub |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Looping & Dumping
Hi, thats great - thanks so much and have a great new Year
"Bob Phillips" wrote: Teresa, Hopefully, this is it Option Explicit Sub SubGetMyData3d() Dim objFSO As Object Dim objFolder As Object Dim objFile As Object Dim owb As Workbook Dim j As Long Dim RngToCopy As Range, Rng2ToCopy As Range Dim intNumRows As Integer, c As Range, lngCellTotal As Long Application.ScreenUpdating = False Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.GetFolder("C:\MyTest\Proposals") j = 1 For Each objFile In objFolder.Files If objFile.Type = "Microsoft Excel Worksheet" Then Set owb = Workbooks.Open(Filename:=objFolder.Path _ & "\" & objFile.Name) With owb.Worksheets("Proposals") Set RngToCopy = .Range("B1:B" _ & .Cells(.Rows.Count, "B").End(xlUp).Row) End With RngToCopy.EntireRow.Copy _ Destination:=ThisWorkbook.Worksheets("Proposals05" ).Cells(j, 1) owb.Close savechanges:=False j = ThisWorkbook.Worksheets("Proposals05") _ .Cells(Rows.Count, "B").End(xlUp).Row + 1 intNumRows = Cells(Rows.Count, "B").End(xlUp).Row End If Next objFile With Worksheets("Proposals05").Range("B" & intNumRows + 1) .Borders(xlEdgeLeft).Weight = xlMedium .Borders(xlEdgeTop).Weight = xlMedium .Value = WorksheetFunction.Sum(Range("B1:B" & intNumRows)) End With Application.ScreenUpdating = True End Sub -- HTH RP (remove nothere from the email address if mailing direct) "teresa" wrote in message ... My Objective: Loop through workbooks in a Folder, then point to "Proposals" worksheet in each workbook, then dump entries into "Proposals05" worksheet in current workbook. The code works if Proposals in 1st wks has "2" Proposals in 2nd wks has "1" Then proposals 05: 2 1 However, if: Proposals in 1st wks has "2" and "122" Proposals in 2nd wks has "1" and "111" Then proposals 05: 2 1 111 instead of all 4 entries, my code below requires slight tweaking, any help is appreciated Sub SubGetMyData3d() Dim objFSO As Object Dim objFolder As Object Dim objFile As Object Dim owb As Workbook Dim j As Long Dim RngToCopy, Rng2ToCopy As Range Dim intNumRows As Integer, c As Range, lngCellTotal As Long Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.GetFolder("C:\My Documents\Career") j = 1: k = 1: l = 1 For Each objFile In objFolder.Files If objFile.Type = "Microsoft Excel Worksheet" Then Set owb = Workbooks.Open(Filename:=objFolder.Path _ & "\" & objFile.Name) With owb.Worksheets("Proposals") Set RngToCopy = .Range("B1:B" _ & .Cells(.Rows.Count, "B").End(xlUp).Row) End With RngToCopy.EntireRow.Copy _ Destination:=Worksheets("Proposals05").Cells(j, 1) j = Worksheets("Proposals05") _ .Cells(Rows.Count, "A").End(xlUp).Row + 1 intNumRows = Cells(50, "B").End(xlUp).Row End If Next objFile For Each c In Worksheets("Proposals05").Range("B1:B" & intNumRows) lngCellTotal = lngCellTotal + c.Value Next 'With Worksheets("Proposals05").Range("B" & intNumRows + 1) ' .Borders(xlEdgeLeft).Weight = xlMedium ' .Borders(xlEdgeTop).Weight = xlMedium ' .Value = lngCellTotal 'End With End Sub |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Dumping Clipboard Memory | Excel Programming | |||
Dumping multi demensioned array into excel | Excel Programming | |||
Help with dumping data | Excel Programming | |||
Need Looping Help | Excel Programming | |||
Dumping the contents of a VBA array to a sheet | Excel Programming |