I am struggling with my VBA code. Instead of fixed values in a table, which contains the names how the workbooks should be saved as. My range needs to be variable (below example for starting with range "A3").
Sheets("CC").Select 'sheet with the names
Range("A3").Select ' starting from this range are the names in a column
Selection.Copy
Sheets("CZK").Select 'going to different sheet to paste some value
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False 'pasting values to different sheet
Application.CutCopyMode = False
Sheets("CC").Select 'returning back to the sheet with names
Nazev = Range("A3")
ActiveWorkbook.SaveAs Filename:=cesta & Nazev 'saving it with predefined path and name
I have to start like this:
Set MyRange = Sheets("CC").Range("A3") ' predefining varible range
Set MyRange = Range(MyRange, MyRange.End(xlDown))
But then I am stuck.
Something like this should work for you:
Sub tst()
Dim wb As Workbook
Dim wsNames As Worksheet
Dim wsDest As Worksheet
Dim NameCells As Range
Dim NameCell As Range
Dim cesta As String
Dim Nazev As String
cesta = "C:\Test\"
Set wb = ActiveWorkbook
Set wsNames = wb.Sheets("CC")
Set wsDest = wb.Sheets("CZK")
Set NameCells = wsNames.Range("A3", wsNames.Cells(wsNames.Rows.Count, "A").End(xlUp))
Application.DisplayAlerts = False
For Each NameCell In NameCells
Nazev = NameCell.Value
wsDest.Range("B2").Value = Nazev
wb.SaveAs cesta & Nazev & ".xlsm", xlOpenXMLWorkbookMacroEnabled
Next NameCell
Application.DisplayAlerts = True
End Sub
Related
I've searched everywhere to see why I'm getting this error. Basically once I get to the last line the "Selection.AutoFill Destination:=Range("G2:M" & LR)" I get the error. The code works if in a separate sub, by itself. Therefore I'm assuming the code above it is somehow affecting it?
Sub Certainsheets()
Dim Wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
Dim LR As Long
Dim rTable As Range
Dim strCellREF2Txt As String
Dim strFILEname As String
Dim WS As Worksheet
'copy from ThisWorkbook
'Set wb2 = Workbooks(2)
Set wb2 = Workbooks.Open("C:\Users\asharma\Desktop\Loan Application\Loan
Data.xls")
'To this
Set Wb1 = ThisWorkbook
'Copying data from Loan Data file
Set tbl = wb2.Sheets(1).Range("A1").CurrentRegion
tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).Copy
'wb2.Sheets(1).Range("A1").CurrentRegion.Copy
'Pasting data into AOL DATA Tab
Wb1.Activate
Sheets("AOL DATA").Range("A10000").End(xlUp).Offset(1, 0).PasteSpecial
xlValues
'Wb1.Sheets(1).Range("A1").Select.PasteSpecial Paste:=xlPasteValues,
'Operation:=xlNone, SkipBlanks _
':=False, Transpose:=False
Application.CutCopyMode = False
wb2.Close
'REMOVING DUPLICATES
'Sheets("AOL DATA").Range("$A:$E").RemoveDuplicates Columns:=1, Header:=xlNo
'This part Autofills the formulas till the last row.
LR = Range("A" & Rows.Count).End(xlUp).Row
Sheets("AOL DATA").Range("G2:M2").Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("G2:M" & LR)
End sub'
Any help would be appreciated
You need to qualify your ranges with the actual sheet, otherwise VBA will default to the ActiveSheet object which may not be what you're expecting in your code.
You can re-write your code as follows:
Sub Certainsheets()
Dim loanWorkbook As Excel.Workbook
Dim aolSheet As Excel.Worksheet
Dim dataTable As Excel.Range
Set loanWorkbook = Workbooks.Open("C:\Users\asharma\Desktop\Loan Application\Loan Data.xls")
Set aolSheet = ThisWorkbook.Sheets("AOL DATA")
Set dataTable = loanWorkbook.Sheets(1).Range("A1").CurrentRegion
With dataTable.Offset(1, 0)
aolData.Range("A" & aolData.Rows.Count).End(xlUp).Offset(1, 0).Value = _
.Resize(.Rows.Count - 1, .Columns.Count).Value
End With
loanWorkbook.Close
With aolSheet
.Range("G2:M2").AutoFill .Range("G2:M" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
End Sub
The AutoFill() method requires the source range to be included as part of the destination range. I suspect because of your code's reliance on ActiveSheet object that you're unknowingly specifying two ranges on different sheets, hence the code fails.
I have prepared a macro which works fine in demo sheet but gives a 1004 runtime error when it put it in the final sheet.
Below is my code:
Private Sub CommandButton3_Click()
'Declaring the Variables
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim rng As Range
Dim startdate As Long
Dim enddate As Long
Dim tbl As ListObject
Dim fname As Variant
'Assigning the Variables
Set ws = Sheets("Reports")
Set ws3 = Sheets("Report Format")
Set rng = ws.Range("E7")
startdate = ws.Range("L10").Value
enddate = ws.Range("L12").Value
'Find the Worksheet against the Name selected in Drop Down List
For Each ws1 In Worksheets
If rng.Value = ws1.Name Then
Sheets(rng.Value).Activate
End If
Next
'Filter the data based on the Date Range Entered
Set ws2 = ActiveSheet
Set tbl = ws2.ListObjects(1)
Range(tbl & "[[Date]:[Cheque #]]").Select
Selection.AutoFilter Field:=1, Criteria1:=">=" & startdate, Operator:=xlAnd, Criteria2:="<=" & enddate
Selection.Copy
ws2.Range("A10").Select
'Paste the Data in the Report Format
ws3.Activate
ws3.Range("B7").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
'Create the PDF of the Report
fname = Application.GetSaveAsFilename(InitialFileName:=rng.Value, filefilter:="PDF files, *.pdf", Title:="Export to PDF")
If fname <> False Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fname_, quality:=xlQualityStandard, includedocproperties:=True, ignoreprintareas:=False, openafterpublish:=True
End If
'Clear the Report format Sheet for Future Printing
With ActiveSheet
.Rows(10 & ":" & .Rows.Count).Delete
End With
'Activate the Report Sheet
ws.Activate
'Unfilter all the Tables present in Workbook
Dim w As Long
For w = 1 To Worksheets.Count
With Worksheets(w)
**.UsedRange.Cells.EntireRow.Hidden = False**
If .AutoFilterMode Then .ShowAllData
End With
Next w
End Sub
Error appears in line which is highlighted in commas. Kindly review and debug.
You are trying to concatenate a ListObject object into a string. You need the ListObject.Name property.
Dim ws2 As Worksheet, tbl As ListObject
Set ws2 = ActiveSheet
Set tbl = ws2.ListObjects(1)
Debug.Print tbl.Name
Range(tbl.Name & "[[Date]:[Cheque '#]]").Select
Please note that there is also a tick (aka ' or Chr(39)) escaping the hashmark in [Cheque '#].
I am new to VBA.
Transposing data from columns in one Workbook to another as rows is throwing errors. Tried suggestions from Stack Overflow and elsewhere but no success.
Error Runtime Error 1004 -> PasteSpecial method of Range class failed
Code:
Sub Button1_Click()
Dim MyFile As String
Dim erow
Dim FilePath As String
FilePath = "C:\trial\"
MyFile = Dir(FilePath)
Do While Len(MyFile) > 0
If MyFile = "here.xlsm" Then
Exit Sub
End If
'Opening data.xls to pull data from one column with 2 values (E6 and E7)
Workbooks.Open (FilePath & MyFile), Editable:=True
Dim SourceRange As Range
Set SourceRange = ActiveSheet.Range("E6:E7")
SourceRange.Copy
ActiveWorkbook.Close SaveChanges:=True
'Back to calling file - here.xlsm and pasting both values in single row (for e.g. A2 and B2)
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Dim targetRange As Range
Set targetRange = ActiveSheet.Cells(erow, 1)
targetRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
MyFile = Dir
Loop
End Sub
It is because you cannot do both values only and transpose at the same time.
Try this:
Sub Button1_Click()
Dim MyFile As String
Dim erow
Dim FilePath As String
Dim swb As Workbook
Dim twb As Workbook
Set twb = ThisWorkbook
FilePath = "C:\trial\"
MyFile = Dir(FilePath)
Do While Len(MyFile) > 0
If MyFile = "here.xlsm" Then
Exit Sub
End If
'Change "Sheet1" below to the actual name of the sheet
erow = twb.Sheets("Sheet1").Cells(twb.Sheets("Sheet1").Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'Opening data.xls to pull data from one column with 2 values (E6 and E7)
Set swb = Workbooks.Open(FilePath & MyFile)
'assign values
twb.Sheets("Sheet1").Cells(erow, 1).Resize(, 2).Value = Application.Transpose(swb.ActiveSheet.Range("E6:E7").Value)
'close
swb.Close SaveChanges:=True
MyFile = Dir
Loop
End Sub
This seems to work:
Its a simpler example that does same thing
copy/paste method applies only to active objects (like, sheets, ranges, etc)
so you need to activate one, then the other,
Sub tst1()
Dim inbook, outbook As Workbook
Dim inSheet, outSheet As Worksheet
Dim inRange, outRange As Range
Set inbook = Application.Workbooks("temp1.xlsx")
Set outbook = Application.Workbooks("temp2.xlsx")
Set inSheet = inbook.Worksheets("sheet1")
Set outSheet = outbook.Worksheets("sheet1")
inSheet.Activate
Set inRange = ActiveSheet.Range("a1:b4")
inRange.Copy
outSheet.Activate
Set outRange = ActiveSheet.Range("a1:d2")
outRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End Sub
Suppose I have a workbook1.xlsm with multiple worksheets and full of various formulas. I want to create a new workbook2.xlsx which would look exactly the same as workbook1 but in all the cells would be values instead of formulas.
I have this macro to copy one sheet from workbook1:
Sub nowe()
Dim Output As Workbook
Dim FileName As String
Set Output = Workbooks.Add
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("Przestoje").Cells.Copy
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats
FileName = ThisWorkbook.Path & "\" & "worksheet2.xlsx"
Output.SaveAs FileName
End Sub
but the problem is it copies only one worksheet and does not name it like it was in worksheet1. I cannot figure it out.
Yet another problem is that worksheet2 is being opened afterwards. I do not want to do this.
How can I solve these problems?
I would do that as simply as possibly, without creating new workbook and copying sheets to it.
Few simple steps: taking into consideration thisworkbook >> for each worksheet within thisworkbook >> copy+paste values of used range within worksheet >> save as new workbook as xlsx type >> open back base workbook >> and finally close one we created.
The code will be simple and looks as follows:
Sub nowe_poprawione()
Dim Output As Workbook
Dim Current As String
Dim FileName As String
Set Output = ThisWorkbook
Current = ThisWorkbook.FullName
Application.DisplayAlerts = False
Dim SH As Worksheet
For Each SH In Output.Worksheets
SH.UsedRange.Copy
SH.UsedRange.PasteSpecial xlPasteValues, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Next
FileName = ThisWorkbook.Path & "\" & "worksheet2.xlsx"
Output.SaveAs FileName, XlFileFormat.xlOpenXMLWorkbook
Workbooks.Open Current
Output.Close
Application.DisplayAlerts = True
End Sub
This should allow you to keep all the formatting, column widths, and only the values.
Option Explicit
Sub copyAll()
Dim Output As Workbook, Source As Workbook
Dim sh As Worksheet
Dim FileName As String
Dim firstCell
Application.ScreenUpdating = False
Set Source = ActiveWorkbook
Set Output = Workbooks.Add
Application.DisplayAlerts = False
Dim i As Integer
For Each sh In Source.Worksheets
Dim newSheet As Worksheet
' select all used cells in the source sheet:
sh.Activate
sh.UsedRange.Select
Application.CutCopyMode = False
Selection.Copy
' create new destination sheet:
Set newSheet = Output.Worksheets.Add(after:=Output.Worksheets(Output.Worksheets.Count))
newSheet.Name = sh.Name
' make sure the destination sheet is selected with the right cell:
newSheet.Activate
firstCell = sh.UsedRange.Cells(1, 1).Address
newSheet.Range(firstCell).Select
' paste the values:
Range(firstCell).PasteSpecial Paste:=xlPasteColumnWidths
Range(firstCell).PasteSpecial Paste:=xlPasteFormats
Range(firstCell).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Next
' delete the sheets that were originally there
While Output.Sheets.Count > Source.Worksheets.Count
Output.Sheets(1).Delete
Wend
FileName = ThisWorkbook.Path & "\" & "worksheet2.xlsx"
Output.SaveAs FileName
Output.Close
Application.ScreenUpdating = True
End Sub
Something like this would work to cycle through and copy all sheets after adding the workbook:
dim i as integer
For i = 1 To ThisWorkbook.Worksheets.Count
ThisWorkbook.Worksheets(i).Activate
ThisWorkbook.Worksheets(i).Select
Cells.Copy
Output.Activate
Dim newSheet As Worksheet
Set newSheet = Output.Worksheets.Add()
newSheet.Name = ThisWorkbook.Worksheets(i).Name
newSheet.Select
Cells.Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Next
Note that this doesn't handle removing default sheets that automatically get created when the workbook gets created.
Also, worksheet2 is actually being opened (though not named til SaveAs) as soon as you call this:
Set Output = Workbooks.Add
Just close it after saving:
Output.Close
Something like this would work to cycle through and copy all sheets after adding the workbook - it builds on mr.Reband's answer, but with a few bells and whistles. Among other things it will work if this is in a third workbook (or an add-in etc), it deletes the default sheet or sheets that were created, it ensures the order of the sheets is the same as the original, etc:
Option Explicit
Sub copyAll()
Dim Output As Workbook, Source As Workbook
Dim sh As Worksheet
Dim FileName As String
Dim firstCell
Application.ScreenUpdating = False
Set Source = ActiveWorkbook
Set Output = Workbooks.Add
Application.DisplayAlerts = False
Dim i As Integer
For Each sh In Source.Worksheets
Dim newSheet As Worksheet
' select all used cells in the source sheet:
sh.Activate
sh.UsedRange.Select
Application.CutCopyMode = False
Selection.Copy
' create new destination sheet:
Set newSheet = Output.Worksheets.Add(after:=Output.Worksheets(Output.Worksheets.Count))
newSheet.Name = sh.Name
' make sure the destination sheet is selected with the right cell:
newSheet.Activate
firstCell = sh.UsedRange.Cells(1, 1).Address
newSheet.Range(firstCell).Select
' paste the values:
Range(firstCell).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Next
' delete the sheets that were originally there
While Output.Sheets.Count > Source.Worksheets.Count
Output.Sheets(1).Delete
Wend
FileName = ThisWorkbook.Path & "\" & "worksheet2.xlsx"
Output.SaveAs FileName
Output.Close
Application.ScreenUpdating = True
End Sub
I will keep this quick. The attached code for the most part works i have used slight variations of it on other projects. the commented out range3.copy is from my last project.
I am currently having issues getting selection.copy to copy the selected range in the correct workbook. I have tried many things some are noted in the script. but I can not get the selection.copy to work
.range.copy will work and populate the clipboard. But I have not figured out how to pastespecial using .copy.
I tried outputting to variable .. didn't work as i thought it might. I feel I have to be missing something on the workbook selection/activation but I don't know what. Thanks in advance for any advice or assistance .. I will continue plugging away and see if I can figure it out.
Here is the first segment with the issue. SRCrange1.select then selection.copy does not actually copy the designated selection. The full code is below.
Dim MyColumn As String
Dim Here As String
Dim AC As Variant
'SRCrange1.copy ': This will copy to clipboard
'objworkbook.Worksheets("plan").Range("b6:h7").Select no change from SRCrange1.select
'SRCrange1.Select 'the range does select
'Selection.copy ' this will cause a activecell in DSTwb _
to be copied neither direct reference to SRCrange1.select or .avtivate will change that.
DSTwb.Select
DSTwb.Range("b2").Select
Here = ActiveCell.Address
MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)
lastrow.Select
Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True
FULL CODE
Sub parse()
Dim strPath As String
Dim strPathused As String
'On Error Resume Next
Set objexcel = CreateObject("Excel.Application")
objexcel.Visible = True
objexcel.DisplayAlerts = False
strPath = "C:\prodplan"
Set objfso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objfso.GetFolder(strPath)
'Loop through objWorkBooks
For Each objfile In objFolder.Files
If objfso.GetExtensionName(objfile.Path) = "xlsx" Then
Set objworkbook = objexcel.Workbooks.Open(objfile.Path)
' Set path for move to at end of script
strPathused = "C:\prodplan\used\" & objworkbook.Name
'open WB to consolidate too
Workbooks.Open "C:\prodplan\compiled\plancon.xlsx"
'Range management sourcebook
Set SRCwb = objworkbook.Worksheets("plan")
Set SRCrange1 = objworkbook.Worksheets("plan").Range("b6:i7")
Set SRCrange2 = objworkbook.Worksheets("plan").Range("k6:p7")
'Set SRCrange3 = objworkbook.Worksheets("").Range("")
'Range management sourcebook
Set DSTwb = Workbooks("plancon.xlsx").Worksheets("data")
'Set DSTrange1 = Workbooks("plancon.xlsx").Worksheets("data").Range("")
'Set DSTrange2 = Workbooks("plancon.xlsx").Worksheets("data").Range("")
'Set DSTrange3 = Workbooks("plancon.xlsx").Worksheets("data").Range("")
'start header dates and shifts copy from objworkbook to consolidated WB
SRCwb.Select
'On Error Resume Next
'SRCwb.Cells.UnMerge
Dim MyColumn As String
Dim Here As String
Dim AC As Variant
'SRCrange1.copy ': This will copy to clipboard
'objworkbook.Worksheets("plan").Range("b6:h7").Select no change from SRCrange1.select
'SRCrange1.Select 'the range does select
'Selection.copy ' this will cause a activecell in DSTwb _
to be copied neither direct reference to SRCrange1.select or .avtivate will change that.
DSTwb.Select
DSTwb.Range("b2").Select
Here = ActiveCell.Address
MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)
lastrow.Select
Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True
SRCrange2.Select
Selection.copy
Workbooks("plancon.xlsx").Worksheets("sheet1").Select
ActiveSheet.Range("b2").Select
ActiveSheet.Range("b2").Activate
Here = ActiveCell.Address
MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)
lastrow.Select
Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True
' range3.copy
' Workbooks("data.xlsx").Worksheets("sheet1").Activate
' ActiveSheet.Range("c2").Select
' ActiveSheet.Range("c2").Activate
' Here = ActiveCell.Address
' MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
' Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)
' ActiveSheet.Paste Destination:=lastrow
'start loop for objworkbook name copy to field in plancon corisponding with date/shift and copy/paste select row data.
objworkbook.Close False
'Move proccesed file to new Dir
OldFilePath = objfile 'original file location
NewFilePath = strPathused ' new file location
Name OldFilePath As NewFilePath ' move the file
End If
Next
objexcel.Quit
End Sub
First, a relative welcome to SO!
Second, some tips for you that will make life easier in VBA programming:
Use Option Explicit and always Dimension and Declare your variable types.
When naming variables, make them easy to understand and follow. So, if you are going to create a worksheet variable, call it something like wksCopy. Or, if you are going to name a workbook, call it wkbCopyTo
You don't need to use .Select and .Activate, but rather you can work directly with your objects. Also, by declaring the appropriate variables types, this make it much easier to work with these objects in your code each time you need them.
I don't know if you are running this code inside Excel, or another application (like Access), but if you are in Excel, there is no need to create an Excel object, as you can work with the Excel App directly. Ignore this if you are using Access / Word / PPT etc to fire the code.
All these tips make your code much easier to read and understand and follow when trying to debug, and write.
All that said, I have refactored your code above to incorporate most of these principles (I kept all your variable names intact so you wouldn't get lost in any re-namings.) If this re-write doesn't directly solve your problem = which it may not, because the code is kind of confusing to me as written, I think it will be much easier for you to follow and understand and find out where it's not doing what you expect when you debug. Also, I think it will help us help you if you can't figure it out.
Sub parse()
Dim strPath As String, strPathused As String
Dim objexcel As Excel.Application
Set objexcel = CreateObject("Excel.Application")
With objexcel
.Visible = True
.DisplayAlerts = False
End With
strPath = "C:\prodplan"
Dim objfso As FileSystemObject, objFolder As Folder
Set objfso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objfso.GetFolder(strPath)
'Loop through objWorkBooks
For Each objfile In objFolder.Files
If objfso.GetExtensionName(objfile.Path) = "xlsx" Then
Dim objWorkbook As Excel.Workbook
Set objWorkbook = objexcel.Workbooks.Open(objfile.Path)
' Set path for move to at end of script
strPathused = "C:\prodplan\used\" & objWorkbook.Name
'open WB to consolidate too
objexcel.Workbooks.Open "C:\prodplan\compiled\plancon.xlsx"
'Range management sourcebook
Dim SRCwb As Excel.Worksheet, SRCrange1 As Excel.Range, SRCrange2 As Excel.Range
Set SRCwb = objWorkbook.Worksheets("plan") 'sjh -> to me wb implies wb, but you set it to a worksheet (could be a style thing, but worth pointing out
Set SRCrange1 = objWorkbook.Worksheets("plan").Range("b6:i7")
Set SRCrange2 = objWorkbook.Worksheets("plan").Range("k6:p7")
'Range management sourcebook
Set DSTwb = Excel.Worksheet
Set DSTwb = Workbooks("plancon.xlsx").Worksheets("data")
'start header dates and shifts copy from objworkbook to consolidated WB
Dim MyColumn As String
Dim Here As String
Dim AC As Variant
Here = DSTwb.Range("B2").Address
MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
'sjh comment -> best to change "ActiveWorkbook" to the workbook referece you mean, like objWorkbook
Dim lastrow As Range
Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)
SRCrange1.Copy
lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True
Here = Workbooks("plancon.xlsx").Worksheets("sheet1").Range("B2").Address
MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
'sjh comment -> best to change "ActiveWorkbook" to the workbook referece you mean, like objWorkbook
Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)
SRCrange2.Copy
lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True
objWorkbook.Close False
'Move proccesed file to new Dir
OldFilePath = objfile 'original file location
NewFilePath = strPathused ' new file location
Name OldFilePath As NewFilePath ' move the file
End If
Next
objexcel.Quit
End Sub
UPDATE If you are running this all in Excel. Just use this code below. I left both codes in my answer, in case you are not running this from Excel.
Option Explicit
Sub parse()
Application.DisplayAlerts = False
Dim strPath As String, strPathused As String
strPath = "C:\prodplan"
Dim objfso As FileSystemObject, objFolder As Folder
Set objfso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objfso.GetFolder(strPath)
'Loop through objWorkBooks
For Each objfile In objFolder.Files
If objfso.GetExtensionName(objfile.Path) = "xlsx" Then
Dim objWorkbook As Workbook
Set objWorkbook = Workbooks.Open(objfile.Path)
' Set path for move to at end of script
strPathused = "C:\prodplan\used\" & objWorkbook.Name
'open WB to consolidate too
Workbooks.Open "C:\prodplan\compiled\plancon.xlsx"
'Range management sourcebook
Dim SRCwb As Worksheet, SRCrange1 As Range, SRCrange2 As Range
Set SRCwb = objWorkbook.Worksheets("plan")
Set SRCrange1 = SRCwb.Range("b6:i7")
Set SRCrange2 = SRCwb.Range("k6:p7")
'Range management sourcebook
Dim DSTwb As Worksheet
Set DSTwb = Workbooks("plancon.xlsx").Worksheets("data")
'start header dates and shifts copy from objworkbook to consolidated WB
Dim MyColumn As String
Dim Here As String
Dim AC As Variant
Here = DSTwb.Range("B2").Address
MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
'sjh comment -> best to change "ActiveWorkbook" to the workbook referece you mean, like objWorkbook or the other workbook you have open
Dim lastrow As Range
Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)
SRCrange1.Copy
lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True
Here = Workbooks("plancon.xlsx").Worksheets("sheet1").Range("B2").Address
MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
'sjh comment -> best to change "ActiveWorkbook" to the workbook referece you mean, like objWorkbook or the other workbook you have open
Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)
SRCrange2.Copy
lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True
objWorkbook.Close False
'Move proccesed file to new Dir
OldFilePath = objfile 'original file location
NewFilePath = strPathused ' new file location
Name OldFilePath As NewFilePath ' move the file
End If
Next
End Sub
Just to add to the other answers: for contiguous ranges you don't need to use copy for this operation (pastespecial >> values + transpose)
Sub CopyValuesTranspose()
Dim rngCopy As Range, rngPaste As Range
Set rngCopy = Range("A1:B10")
Set rngPaste = Range("D1")
rngPaste.Resize(rngCopy.Columns.Count, rngCopy.Rows.Count).Value = _
Application.Transpose(rngCopy.Value)
End Sub
no need to select a range and then copy the selection, when you can copy a range directly:
objworkbook.Worksheets("plan").Range("b6:h7").Copy
same_or_different_Range.PasteSpecial Paste:=xlPasteValues, _
operation:=xlNone, skipblanks:=False, Transpose:=True