I have to copy data in excel from B5:L16 and paste it in another worksheet on C3:M14. I have the below code which copies the entire sheet. I am not able to identify the correct cell number.
Set wkbImportedWorkbook = ActiveWorkbook
Set wksImportedWorksheet = wkbImportedWorkbook.Sheets("Summary")
Set rngImportCopyRange = Range(wksImportedWorksheet.Cells(1, 1), Cells(5000, 1)).EntireRow
rngImportCopyRange.Copy wksMasterWorksheet.Cells(1, 1)
rngImportCopyRange.Copy
wksMasterWorksheet.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
wkbMasterWorkbook.Activate
Application.DisplayAlerts = False
wkbImportedWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
wksMasterWorksheet.Activate
wksMasterWorksheet.Cells(1, 1).Select
Application.ScreenUpdating = True
Related
I have been searching for the answer to this question and have found some helpful hints but can't make it work within this code.
I'm copying three tabs and the workbook's name is in Cover!R11 but the other two tabs from that file need the filename as well with an extension (i.e. Filename, Cover, Filename Summary, Filename Estimate). If I reference the cell with the filename when I'm on the second sheet, how can I reference the previous sheet? That's why I thought it easier to use the Filename instead. I tried using: Sheets(SheetName1).Name = FilePath but I can't figure out how to trim it within this code. Can you help?
Here's the code:
Sub CopySheets()
Dim DialogBox As FileDialog
Dim FilePath As String
Dim SheetName As String
Set DialogBox = Application.FileDialog(msoFileDialogFilePicker)
DialogBox.Title = "Select Estimates to copy " & FileType
DialogBox.AllowMultiSelect = True
DialogBox.Filters.Clear
DialogBox.Show
If DialogBox.SelectedItems.Count = 1 Then
FilePath = DialogBox.SelectedItems(1)
End If
For i = 1 To DialogBox.SelectedItems.Count
Application.ScreenUpdating = False
Application.DisplayAlerts = False
FilePath = DialogBox.SelectedItems(i)
SheetName1 = "Cover"
SheetName2 = "Summary"
SheetName3 = "Estimate and Schedule "
Set closedBook = Workbooks.Open(FilePath)
closedBook.Sheets(SheetName1).Copy
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Range("B2:Z97").Select
Selection.Copy
Application.CutCopyMode = False
ActiveSheet.Unprotect Password:="zxc"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'The file name I want to use is in this field, but I can't reference it for the other tabs.
Sheets(SheetName1).Name = Range("R11")
closedBook.Sheets(SheetName2).Copy
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Range("B5:K39").Select
Selection.Copy
Application.CutCopyMode = False
ActiveSheet.Unprotect Password:="zxc"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'This line here didn't work to pull the previous sheet's value in R11
'Sheets(SheetName2).Name = prevname.Range("R11") & "Summary"
closedBook.Sheets(SheetName3).Copy
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Range("A3:M70").Select
Selection.Copy
Application.CutCopyMode = False
ActiveSheet.Unprotect Password:="zxc"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
closedBook.Close SaveChanges:=False
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
If you want to use the value from 'Cover'!R11 later in the code store it in a variable.
'The file name I want to use is in this field, but I can't reference it for the other tabs.
Dim strFilename As String
' other code
strFilename = Sheets("Cover").Range("R11").Value
Sheets(SheetName1).Name = strFilename
' more code
Sheets(SheetName2).Name = strFilename & " Summary"
' even more code
Sheets(SheetName2).Name = strFilename & " Estimate"
I have the following code which should:
Open the selected files
Copy the three tabs indicated to another workbook
I thought this was working ok but then I realized that it's copying the first selected file the same amount of times as the number of selected files. So basically, it's not opening the other files and copying the tabs to the template. Can you help?
Sub CopySheets()
Dim DialogBox As FileDialog
Dim FilePath, SheetName As String
Set DialogBox = Application.FileDialog(msoFileDialogFilePicker)
DialogBox.Title = "Select Estimates to copy " & FileType
DialogBox.AllowMultiSelect = True
DialogBox.Filters.Clear
DialogBox.Show
If DialogBox.SelectedItems.Count = 1 Then
FilePath = DialogBox.SelectedItems(1)
End If
For i = 1 To DialogBox.SelectedItems.Count
Application.ScreenUpdating = False
Application.DisplayAlerts = False
FilePath = DialogBox.SelectedItems(1)
SheetName1 = "Cover"
SheetName2 = "Summary"
SheetName3 = "Estimate and Schedule "
Set closedBook = Workbooks.Open(FilePath)
closedBook.Sheets(SheetName1).Copy
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Range("B2:Z97").Select
Selection.Copy
Application.CutCopyMode = False
ActiveSheet.Unprotect Password:="zxc"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets(SheetName1).Name = i 'I would like this to be the File Name
closedBook.Sheets(SheetName2).Copy
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Range("B5:K39").Select
Selection.Copy
Application.CutCopyMode = False
ActiveSheet.Unprotect Password:="zxc"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
closedBook.Sheets(SheetName3).Copy
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Range("A3:M70").Select
Selection.Copy
Application.CutCopyMode = False
ActiveSheet.Unprotect Password:="zxc"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
closedBook.Close SaveChanges:=False
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
The title says most of it what I am looking to create is an inventory management system to handle the inventory for my area but I keep getting runtime errors in my code, I am not super proficient at VBA but I have a base knowledge. Code I am working on is below, any help would be awesome.
Edit:
Specific runtime error is 1004: Select Method of Range class failed on line 15 after is has already copy and pasted one.
Sub add2Order()
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim C As range, Rng As range, D As range, Rng1 As range
Set Rng = range("K6", range("K6").End(xlDown))
For Each C In Rng
If InStr(1, C, "X") > 0 Then
'first select material number and name
range(C.Offset(0, -9), C.Offset(0, -8)).Select
Application.CutCopyMode = False
Selection.Copy
'paste in reorder sheet
Sheets("Re-Order List").Select
Selection.End(xlDown).Select
range("A65536").Select
Selection.End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = True
End If
Next
Set Rng1 = range("K6", range("K6").End(xlDown))
For Each D In Rng1
If InStr(1, D, "X") > 0 Then
'Second select amount and cost
range(D.Offset(0, -2), D.Offset(0, -1)).Select
Application.CutCopyMode = False
Selection.Copy
'paste in reorder sheet
Sheets("Re-Order List").Select
Selection.End(xlDown).Select
range("C65536").Select
Selection.End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = True
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Inventory sheet to copy from
Reorder sheet to paste in
If you remove "select" your macro should look like this:
Sub add2Order()
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim C As Range, Rng As Range, D As Range, Rng1 As Range
Set Rng = Range("K6", Range("K6").End(xlDown))
For Each C In Rng
If InStr(1, C, "X") > 0 Then
'first select material number and name
Application.CutCopyMode = False
Range(C.Offset(0, -9), C.Offset(0, -8)).Copy
'paste in reorder sheet
Sheets("Re-Order List").Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = True
End If
Next
Set Rng1 = Range("K6", Range("K6").End(xlDown))
For Each D In Rng1
If InStr(1, D, "X") > 0 Then
'Second select amount and cost
Application.CutCopyMode = False
Range(D.Offset(0, -2), D.Offset(0, -1)).Copy
'paste in reorder sheet
Sheets("Re-Order List").Range("C65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = True
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
If you run a macro on sheets (1) and You do "select" or "active" sheets (2) in your code, excel has a problem because both sheets are therefore indicated as active.
I am new to Excel VBA and was recently tasked with creating a macro that copys from one worksheet containing drop-down lists and formulas to another "output" sheet that keeps these in a nice list(table) for reference.
My code was designed to do a simple copy from sheet1 and pastevalue to sheet2 and set up to search for the last cell containing data in a row and then offset it to paste below into an empty cell. This works for most of what I am trying to do but I am running into an issue where one part of the code is not pasting properly in row "J".
Here is my code:
Sub TestCopyToDB()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Set copySheet = Worksheets("PIT Training Request Form")
Set pasteSheet = Worksheets("Output")
copySheet.Range("C2:D2").Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
copySheet.Range("C3").Copy
pasteSheet.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
copySheet.Range("C4").Copy
pasteSheet.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
copySheet.Range("C5").Copy
pasteSheet.Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
copySheet.Range("C6").Copy
pasteSheet.Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
copySheet.Range("C7").Copy
pasteSheet.Cells(Rows.Count, 6).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
copySheet.Range("C8").Copy
pasteSheet.Cells(Rows.Count, 7).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
copySheet.Range("E8").Copy
pasteSheet.Cells(Rows.Count, 8).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
copySheet.Range("C11:D11").Copy
pasteSheet.Cells(Rows.Count, 9).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
copySheet.Range("H16").Copy
pasteSheet.Cells(Rows.Count, 10).End(xlUp).Offset(1, 0).Row.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=xlCopy, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
Sheets("PIT Training Request Form").Range("C3").ClearContents
Sheets("PIT Training Request Form").Range("C4").ClearContents
Sheets("PIT Training Request Form").Range("C5").ClearContents
Sheets("PIT Training Request Form").Range("C6").ClearContents
Sheets("PIT Training Request Form").Range("C7").ClearContents
Sheets("PIT Training Request Form").Range("C8").ClearContents
Sheets("PIT Training Request Form").Range("C11:D11").ClearContents
Sheets("PIT Training Request Form").Range("E8").ClearContents
Sheets("PIT Training Request Form").Range("D9").ClearContents
Sheets("PIT Training Request Form").Range("D10").ClearContents
Sheets("PIT Training Request Form").Range("D14").ClearContents
Sheets("PIT Training Request Form").Range("D15").ClearContents
Sheets("PIT Training Request Form").Range("D16").ClearContents
End With
Sheets("PIT Training Request Form").Select
MsgBox "Submission Complete.", vbInformation
End Sub
The last copy and paste line from H16 will paste but it is not finding the empty cells below and is overwriting information above it. I am not sure why.
Any and all help is appreciated.
Thank you,
A general suggestion would be to set the output range. It's a little unclear which column is "J" in your code above. It looks like your paste for that "H16" copy command is referencing Row.PasteSpecial which is likely the cause of your error:
copySheet.Range("H16").Copy
pasteSheet.Cells(Rows.Count, 10).End(xlUp).Offset(1, 0).Row.PasteSpecial
I've looped the copying/pasting in your code above. This may be a little easier to manipulate and debug.
dim copyRngs as Variant, copyRng as Range, outRng as Range
copyRngs = Array("C2:D2","C3","C4","C5","C6","C7","C8","E8","C11:C16","H16")
set outRng = pasteSheet.Range("A1")
For i = lbound(copyRngs) to ubound(copyRngs)
application.screenupdating = False
Set copyRng = copySheet.Range(copyRngs(i))
copyRng.Copy
outRng.Resize(copyRng.Cells.Count).Offset(copyRng.Row,End(xlUp)).PasteSpecial xlPasteValues
copyRng.ClearContents
application.screenupdating = True
application.cutcopymode = false
Next i
I feel like your code is more complicated than it needs to be. I have created some new code for you that is a lot easier. You will need to put in the actual values but I think I made it simple enough to follow.
Sub logInformation()
'GET VALUES
Dim fName As String
Dim lName As String
Dim age As String
Dim gender As String
fName = Sheet1.Range("B2")
lName = Sheet1.Range("C2")
age = Sheet1.Range("B3")
gender = Sheet1.Range("B4")
'INSERT VALUES
Dim tbl As ListObject
Set tbl = Sheet2.ListObjects("Table1")
Dim row As ListRow
Set row = tbl.ListRows.Add
With row
.Range(1) = fName
.Range(2) = lName
.Range(3) = age
.Range(4) = gender
End With
'CLEAR FORM
Sheet1.Range("B2").Clear
Sheet1.Range("C2").Clear
Sheet1.Range("B3").Clear
Sheet1.Range("B4").Clear
End Sub
-- OR --
You could also loop it and make it a lot easier
Sub logInformation()
Dim tbl As ListObject
Set tbl = Sheet2.ListObjects("Table1")
Dim row As ListRow
Set row = tbl.ListRows.Add
Dim arr As Variant
arr = Array("C2", "D2", "C3", "C4", "C5", "C6", "C7", "C8", "E8", "C11", "C12", "C13", "C14", "C15", "C16", "H16")
For i = LBound(arr) To UBound(arr)
row.Range(i + 1) = Sheet1.Range(arr(i)).value
Sheet1.Range(arr(i)).Clear
Next i
End Sub
I'm trying to write a macro that will Open files one by one in a provided directory, calculate all formulas, paste values over specific formulas, save, and exit, repeat process with next file. Here's what i have below:
Sub LoopPaloSnapshot()
Dim wb As Workbook
Dim ws As Worksheet
Dim MyPath As String
Dim FldrPicker As FileDialog
Dim FSO As New FileSystemObject
Dim MyFolder As Folder
Dim SubFolder As Folder
Dim MyFile2 As File
Application.ScreenUpdating = True
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
MyPath = .SelectedItems(1) & "\"
End With
Set FSO = CreateObject("scripting.filesystemobject")
'In Case of Cancel
NextCode:
MyPath = MyPath
Set MyFolder = FSO.GetFolder(MyPath)
For Each SubFolder In MyFolder.SubFolders
For Each MyFile2 In SubFolder.Files
If FSO.GetExtensionName(MyFile2.Path) = "xlsx" Then
Set wb = Workbooks.Open(Filename:=MyFile2, UpdateLinks:=0)
Set ws = wb.Worksheets("Staffing Model")
Application.Run ("PALO.CALCSHEET")
Application.Calculate
Application.Run ("PALO.CALCSHEET")
Application.Calculate
Application.Calculation = xlCalculationManual
ws.Range("B1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ws.Range("F10:Q10").Value = ws.Range("F10:Q10").Value
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ws.Range("F20:Q22").Value = ws.Range("F20:Q22").Value
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ws.Range("F42:Q43").Value = ws.Range("F42:Q43").Value
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ws.Range("F56:Q56").Value = ws.Range("F56:Q56").Value
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ws.Range("F61:Q61").Value = ws.Range("F61:Q61").Value
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ws.Range("F66:Q66").Value = ws.Range("F66:Q66").Value
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
'Break Links
If Not IsEmpty(wb.LinkSources(xlExcelLinks)) Then
For Each link In wb.LinkSources(xlExcelLinks)
wb.BreakLink link, xlLinkTypeExcelLinks
Next link
End If
Dim xWs As Worksheet
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Staffing Model" Then
xWs.Delete
End If
Next
'Save and Close Workbook
wb.Close SaveChanges:=True
'Loop
End If
Next
Next
MsgBox "Task Complete!"
ResetSettings:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
After running this, i open the newly saved files and there are #Value errors in place of the formulas im attempting to calculate and paste values over. I've tried walking through the macro line by line and it seems to be working properly for the most part, but for some reason the formulas are not calculating. if i open the file manually prior to running the macro, everything calculates perfectly so im wondering if something is causing these formulas to not calculate while the macro is running. any help would be appreciated.
EDIT: the formulas im copying and pasting values over are HLOOKUP's pulling from other tabs within the workbook, and PALO formulas pulling data directly from a JEDOX server. i've manually ran through the process im trying to automate without errors.
Instead of copying and pasting complex formulas, I'd suggest writing the formulas directly into the cells using this method:
Worksheets("Sheet1").Range("A1").Formula = "=$A$4+$A$10"
Pasted formulas can sometimes carry references to the original worksheet which causes chaos, whereas an explicitly set formula will not do that.
If you're really trying to take it offline then you could also use this method to set values as well.
Worksheets("Sheet1").Range("A1").Value = "100"