I'm having a hard time trying to go through each worksheet in a workbook, get the name of a worksheet from another workbook and rename my main workbook worksheet. So, right now I have it so that the user can select a file they want to copy over to a new workbook with a different layout then the old one they have used. Then it gets the count of how many worksheets are in the old workbook and copies the worksheet in the new (Main)workbook. Afterwards it gets the name of each tab and renames the worksheet in the new (Main)workbook.
Mostly having trouble in this area of the code
For i = 1 To sheetcounts
wbCopyTo.Activate
wsCopyTo.Copy After:=ActiveSheet
wbCopyTo.Worksheets(1).Activate
'wbCopyFrom.Sheets(ActiveSheet.Index + 1).Select
wbCopyFrom.ActiveSheet.Next.Activate
wbCopyTo.ActiveSheet.Name = wbCopyFrom.ActiveSheet.Name
Here is the whole thing
`Sub CpyOldTest()
Dim vFile As Variant
Dim wbCopyTo As Workbook
Dim wsCopyTo As Worksheet
Dim wbCopyFrom As Workbook
Dim wsCopyFrom As Worksheet
Dim cCounter As Integer
Dim rCounter As Integer
Dim sheetcounts As Integer
Dim i As Integer
Set wbCopyTo = ThisWorkbook
Set wsCopyTo = ActiveSheet
'On Error Resume Next
'-------------------------------------------------------------
'Open file with data to be copied
vFile = Application.GetOpenFilename("Excel Files (*.xl*)," & _
"*.xl*", 1, "Select Excel File", "Open", False)
'If Cancel then Exit
If TypeName(vFile) = "Boolean" Then
Exit Sub
Else
Set wbCopyFrom = Workbooks.Open(vFile)
Set wsCopyFrom = wbCopyFrom.Worksheets(Sheets.Count)
'Get Count and Copy
sheetcounts = wbCopyFrom.Worksheets.Count - 1
For i = 1 To sheetcounts
wbCopyTo.Activate
wsCopyTo.Copy After:=ActiveSheet
wbCopyTo.Worksheets(1).Activate
'wbCopyFrom.Sheets(ActiveSheet.Index + 1).Select
wbCopyFrom.ActiveSheet.Next.Activate
wbCopyTo.ActiveSheet.Name = wbCopyFrom.ActiveSheet.Name
'Copy Range
Application.ScreenUpdating = False
'Patient Information
wsCopyFrom.Range("B2:B10").Copy
wsCopyTo.Range("B2:B10").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Physician and Home Health care
wsCopyFrom.Range("C12:C17").Copy
wsCopyTo.Range("C12:C17").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Diagnosis/TPN/Assessment Type
wsCopyFrom.Range("B19:D21").Copy
wsCopyTo.Range("B19:D21").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Calculated Needs
wsCopyFrom.Range("E5").Copy
wsCopyTo.Range("E5").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wsCopyFrom.Range("E7").Copy
wsCopyTo.Range("E7").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wsCopyFrom.Range("E9:E10").Copy
wsCopyTo.Range("E9:E10").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wsCopyFrom.Range("E12:E14").Copy
wsCopyTo.Range("E12:E14").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Intake/Lipids
wsCopyFrom.Range("B23:C28").Copy
wsCopyTo.Range("B23:C28").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'TPN Components
wsCopyFrom.Range("C30:C37").Copy
wsCopyTo.Range("C30:C37").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'IBW adjustment
wsCopyFrom.Range("F1").Copy
wsCopyTo.Range("F1").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Protein Needs
'wsCopyFrom.Range("F12").Copy
'wsCopyTo.Range("F12").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Notes
wsCopyFrom.Range("E19:F23").Copy
wsCopyTo.Range("E19:F23").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Intake
wsCopyFrom.Range("D23").Copy
wsCopyTo.Range("D23").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Amino Acid
wsCopyFrom.Range("D25").Copy
wsCopyTo.Range("D25").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Total MLs
wsCopyFrom.Range("D27").Copy
wsCopyTo.Range("D27").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'KCal
wsCopyFrom.Range("D29").Copy
wsCopyTo.Range("D29").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'IV/Lipid/Fluid Bags
wsCopyFrom.Range("E25:E27").Copy
wsCopyTo.Range("E25:E27").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Access Device
wsCopyFrom.Range("F29:F30").Copy
wsCopyTo.Range("F29:F30").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Lab Frequency
wsCopyFrom.Range("F33").Copy
wsCopyTo.Range("F32").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'-------------------------------------------------------------------
'Lab Data
wsCopyFrom.Range("J2:P12").Copy
wsCopyTo.Range("J2:P12").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wsCopyFrom.Range("J14:P32").Copy
wsCopyTo.Range("J14:P32").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wsCopyFrom.Range("G4:H32").Copy
wsCopyTo.Range("G4:H32").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wsCopyFrom.Range("I25:I32").Copy
wsCopyTo.Range("I25:I32").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'TPN
wsCopyFrom.Range("K34:P41").Copy
wsCopyTo.Range("K37:P44").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wsCopyFrom.Range("K43:P50").Copy
wsCopyTo.Range("K46:P53").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'------------------------------------------------------------------
'Additives
wsCopyFrom.Range("B39:F39").Copy
wsCopyTo.Range("B42:F42").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Subjective
wsCopyFrom.Range("A41:F47").Copy
wsCopyTo.Range("A44:F50").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Meds
wsCopyFrom.Range("A50:F50").Copy
wsCopyTo.Range("A53:F53").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Assessment Diagnosis
wsCopyFrom.Range("A53:F56").Copy
wsCopyTo.Range("A56:F59").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Nutrition Goals
wsCopyFrom.Range("A59:F63").Copy
wsCopyTo.Range("A62:F66").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Plan of Care
wsCopyFrom.Range("A66:F72").Copy
wsCopyTo.Range("A69:F75").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'------------------------------------------------------------------
'List of Dietitians
wsCopyFrom.Range("K62:P67").Copy
wsCopyTo.Range("K65:P70").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Dates
wsCopyFrom.Range("C73:C74").Copy
wsCopyTo.Range("C76:C77").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Education
wsCopyFrom.Range("B75:H75").Copy
wsCopyTo.Range("B78:H78").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Discussed
wsCopyFrom.Range("B76:D76").Copy
wsCopyTo.Range("B79:D79").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Dietitian
wsCopyFrom.Range("A79:B80").Copy
wsCopyTo.Range("A82:B82").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Evaluation
wsCopyFrom.Range("D79:E79").Copy
wsCopyTo.Range("D82:E82").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Pharmacy Information
wsCopyFrom.Range("B86:D87").Copy
wsCopyTo.Range("B89:D90").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wsCopyFrom.Range("B88:B89").Copy
wsCopyTo.Range("B91:B92").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Next due dates
wsCopyFrom.Range("G86:G89").Copy
wsCopyTo.Range("G89:G92").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next i
'Close file that was opened
wbCopyFrom.Close SaveChanges:=False
Application.ScreenUpdating = True
End If
End Sub
I've tried many ways to get pass this and still no luck. Just wondering if I can get some help here. Sorry about the bad layout of the code just trying to get this done before I clean it up. Thank you.
There is no reason to activate the sheets.
Create a function to copy the Template and return a reference to the new worksheet.
For each ws in Worksheets is preferable over For i = 1 to Worksheets.Count
If you just want to copy the values of a contiguous range, it is better to do a direct assignment Range("B1:B10").Value =Range("A1:A10").VAlueas opposed toRange("A1:A10").Copy: Range("B1:B10").PasteSpecial xlPasteValues
The Worksheets collection starts at index 1. This loop ships the last worksheet.
sheetcounts = wbCopyFrom.Worksheets.Count - 1
Set wsCopyFrom = wbCopyFrom.Worksheets(Sheets.Count)
Sub CpyOldTest()
Dim vFile As Variant
Dim wbCopyFrom As Workbook, wsTemplate As Workbook
Dim ws As Worksheet
'On Error Resume Next
Set wsTemplate = ThisWorkbook.Worksheets("Template")
'-------------------------------------------------------------
'Open file with data to be copied
vFile = Application.GetOpenFilename("Excel Files (*.xl*)," & _
"*.xl*", 1, "Select Excel File", "Open", False)
'If Cancel then Exit
If TypeName(vFile) = "Boolean" Then
Exit Sub
Else
Application.ScreenUpdating = False
Set wbCopyFrom = Workbooks.Open(vFile)
For Each ws In wbCopyFrom.Worksheets
With getTemplateCopy
.Name = ws.Name
.Range("B2:B10").Value = ws.Range("B2:B10").Value 'Patient Information
.Range("C12:C17").Value = ws.Range("C12:C17").Value 'Physician and Home Health care
.Range("B19:D21").Value = ws.Range("B19:D21").Value 'Diagnosis/TPN/Assessment Type
'-------------------------------------------------------------------
'Calculated Needs
.Range("E5").Value = ws.Range("E5").Value
.Range("E7").Value = ws.Range("E7").Value
.Range("E9:E10").Value = ws.Range("E9:E10").Value
.Range("E12:E14").Value = ws.Range("E12:E14").Value
'-------------------------------------------------------------------
.Range("B23:C28").Value = ws.Range("B23:C28").Value 'Intake/Lipids
.Range("C30:C37").Value = ws.Range("C30:C37").Value 'TPN Components
.Range("F1").Value = ws.Range("F1").Value 'IBW adjustment
'.Range("F12").value = ws.Range ("F12").value 'Protein Needs
.Range("E19:F23").Value = ws.Range("E19:F23").Value 'Notes
'-------------------------------------------------------------------
.Range("D23").Value = ws.Range("D23").Value 'Intake
.Range("D25").Value = ws.Range("D25").Value 'Amino Acid
.Range("D27").Value = ws.Range("D27").Value 'Total MLs
.Range("D29").Value = ws.Range("D29").Value 'KCal
.Range("E25:E27").Value = ws.Range("E25:E27").Value 'IV/Lipid/Fluid Bags
.Range("F29:F30").Value = ws.Range("F29:F30").Value 'Access Device
.Range("F32").Value = ws.Range("F33").Value 'Lab Frequency
'-------------------------------------------------------------------
'Lab Data
.Range("J2:P12").Value = ws.Range("J2:P12").Value
.Range("J14:P32").Value = ws.Range("J14:P32").Value
.Range("G4:H32").Value = ws.Range("G4:H32").Value
.Range("I25:I32").Value = ws.Range("I25:I32").Value
.Range("K37:P44").Value = ws.Range("K34:P41").Value 'TPN
.Range("K46:P53").Value = ws.Range("K43:P50").Value
'------------------------------------------------------------------
.Range("B42:F42").Value = ws.Range("B39:F39").Value 'Additives
.Range("A44:F50").Value = ws.Range("A41:F47").Value 'Subjective
.Range("A53:F53").Value = ws.Range("A50:F50").Value 'Meds
.Range("A56:F59").Value = ws.Range("A53:F56").Value 'Assessment Diagnosis
.Range("A62:F66").Value = ws.Range("A59:F63").Value 'Nutrition Goals
.Range("A69:F75").Value = ws.Range("A66:F72").Value 'Plan of Care
'------------------------------------------------------------------
.Range("K65:P70").Value = ws.Range("K62:P67").Value 'List of Dietitians
.Range("C76:C77").Value = ws.Range("C73:C74").Value 'Dates
.Range("B78:H78").Value = ws.Range("B75:H75").Value 'Education
.Range("B79:D79").Value = ws.Range("B76:D76").Value 'Discussed
.Range("A82:B82").Value = ws.Range("A79:B80").Value 'Dietitian
.Range("D82:E82").Value = ws.Range("D79:E79").Value 'Evaluation
'------------------------------------------------------------------
'Pharmacy Information
.Range("B89:D90").Value = ws.Range("B86:D87").Value
.Range("B91:B92").Value = ws.Range("B88:B89").Value
'------------------------------------------------------------------
.Range("G89:G92").Value = ws.Range("G86:G89").Value 'Next due dates
End With
Next
'Close file that was opened
wbCopyFrom.Close SaveChanges:=False
Application.ScreenUpdating = True
End If
End Sub
Function getTemplateCopy() As Worksheet
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Template")
ws.Copy After:=ws
Set getTemplateCopy = ThisWorkbook.ActiveSheet
End Function
Related
I am trying to figure this out and I am hoping you can help
Basically I have Form and Data Sheet. I am looking to copy the information in the form into a new blank row within Table1 on the data sheet,
I have managed to get as far as the following but this causes the data to be over written each time, (rather than a a new row).
Sub Macro1()
Sheets("Form").Select
Range("G5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Data").Select
Range("Table1[[#Headers],[ID]]").Select
Selection.End(xlDown).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Form").Select
Range("D3").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Data").Select
Range("Table1[[#Headers],[Contact Date]]").Select
Selection.End(xlDown).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Form").Select
Range("D4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Data").Select
Range("Table1[[#Headers],[Channel]]").Select
Selection.End(xlDown).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Form").Select
Range("D5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Data").Select
Range("Table1[[#Headers],[Agent Name]]").Select
Selection.End(xlDown).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Form").Select
Range("D6").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Data").Select
Range("Table1[[#Headers],[Contact ID]]").Select
Selection.End(xlDown).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Form").Select
Range("G3").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Data").Select
Range("Table1[[#Headers],[Scored by]]").Select
Selection.End(xlDown).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Form").Select
Range("G4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Data").Select
Range("Table1[[#Headers],[Team Leader]]").Select
Selection.End(xlDown).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
I realise this may seem like a simple question but I am struggling to work this out.
FYI - There will be 29 Columns to this table so If I should be doing something to make this cleaner, please let me know
Here's a more streamlined way to approach this:
EDIT - updated to add "config" array to reduce repetition
Sub Transfer()
Dim config, itm, arr
Dim rw As Range, listCols As ListColumns
Dim shtForm As Worksheet
Set shtForm = Worksheets("Form") '<< data source
With Sheets("Data").ListObjects("Table1")
Set rw = .ListRows.Add.Range 'add a new row and get its Range
Set listCols = .ListColumns 'get the columns collection
End With
'array of strings with pairs of "[colname]<>[range address]"
config = Array("ID<>G5", "Contact Date<>D3", "Channel<>D4")
'loop over each item in the config array and transfer the value to the
' appropriate column
For Each itm In config
arr = Split(itm, "<>") ' split to colname and cell address
rw.Cells(listCols(arr(0)).Index).Value = shtForm.Range(arr(1)).Value
Next itm
End Sub
No copy/paste/select/activate required.
I have made a Macro that performs some repetitive tasks (updates certain data connections and transfers this information to another Excel). The code works perfectly, however, sometimes, it changes the formatting of certain cells, in worksheets, that are not even called in the Macro.
This sounds as a bug. I have previously had the same problem, that was solved by removing the On Error Resume Next line.
Could you please read my code, and see if there is something that could be causing this bug? I really cannot allow to lose my formatting since I am using these sheets for important company reports.
Before running the Macro:
After running the Macro:
Here goes my code:
Sub TRANSFER_INPUT()
'
' TRANSFER_INPUT Macro
'
Dim MWWorkBook As Workbook
Set MWWorkBook = ActiveWorkbook
Sheets("PAR").Select
Dim Pateka As String
Worksheets("PAR").Activate
Pateka = Range("E5").Value
Dim Datum1 As String
Worksheets("PAR").Activate
Datum1 = Range("E6").Value
Dim InputExcel As Workbook
Workbooks.Open Filename:=Pateka & "INPUT" & Datum1 & ".xlsx", UpdateLinks:=3
Set InputExcel = ActiveWorkbook
'###
'MAIN WORKBOOK / PREFRLANJE FAJLOVI
'###
'INPUTBILANS
MWWorkBook.Activate
Sheets("INPUTBILANS").Select
Range("F11:M1000").Select
Selection.Copy
Range("Y11").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'REFRESH BILANS VO INPUT
MWWorkBook.Activate
Sheets("INPUTBILANS").Select
Range("F10").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
'###
'###
'PREFRLI VO INPUT
'###
'###
'Kopiraj Bilans_1
Range("F11:V1000").Select
Selection.Copy
'Pastiraj Bilans_1 VO INPUT / Bilans_1 vo Bilans_2
InputExcel.Activate
Sheets("BILANS_1").Select
Range("B8").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("B8:R1000").Select
Selection.Copy
Sheets("BILANS_2").Select
Range("B8").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
''' PREFRLI I KOPIRAJ COSTS
MWWorkBook.Activate
Sheets("COSTS").Select
Range("A4").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("A5:AV312").Select
Selection.Copy
InputExcel.Activate
Sheets("COSTS").Activate
Range("A5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Kopiraj OPER.COST
MWWorkBook.Activate
Sheets("OPER.COST | NONOP | PRIHODI").Select
Range("D7").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("G16:P63").Select
Selection.Copy
InputExcel.Activate
Sheets("OPER.COST").Select
Range("Z4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Kopiraj PRIHODI
MWWorkBook.Activate
Sheets("OPER.COST | NONOP | PRIHODI").Select
Range("D65:F204").Select
Selection.Copy
InputExcel.Activate
Sheets("PRIHODI").Select
Range("B4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Kopiraj NONOP
MWWorkBook.Activate
Sheets("OPER.COST | NONOP | PRIHODI").Select
Range("F8:F14").Select
Selection.Copy
InputExcel.Activate
Sheets("NONOP").Select
Range("D5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
Thank you so much!
So I wrote a fairly simple Macro in VBA that updates a set of variables, then copying and pasting the updated values into a new sheet. The problem is that the volume is getting a bit overwhelming now, thus reaching the 1,048,576 row limit in Excel, causing the code to crash.
I would like to update it so that whenever the rows limitation is reached, the script begins copying the cells to a new sheet (say, "FinalFile2","FinalFile3", etc) until it's fully executed.
Sub KW()
'
' Exact KWs
'
Dim i, j, LastRow As Long
Dim relativePath As String
i = 2
j = 2
'LastRowValue'
Sheets("Output").Select
LastRow = Rows(Rows.Count).End(xlUp).Row - 1
'Clean final output'
Sheets("FinalFile").Select
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("A1").Select
'Set Variables in Variables sheet'
Do
'Var 1'
Sheets("Names").Select
Range("A" & i).Select
Selection.Copy
Sheets("Variables").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Var 2'
Sheets("Names").Select
Range("B" & i).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Variables").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Var 3'
Sheets("Names").Select
Range("C" & i).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Variables").Select
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Var 4'
Sheets("Names").Select
Range("D" & i).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Variables").Select
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Var 5'
Sheets("Names").Select
Range("E" & i).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Variables").Select
Range("E2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Var 6'
Sheets("Names").Select
Range("F" & i).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Variables").Select
Range("F2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Var 7'
Sheets("Names").Select
Range("G" & i).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Variables").Select
Range("G2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Var 8'
Sheets("Names").Select
Range("H" & i).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Variables").Select
Range("H2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Var 9'
Sheets("Names").Select
Range("I" & i).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Variables").Select
Range("I2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Var 10'
Sheets("Names").Select
Range("J" & i).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Variables").Select
Range("J2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Var 11'
Sheets("Names").Select
Range("K" & i).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Variables").Select
Range("K2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Copy and Paste'
Sheets("Output").Select
Range("A2:AP2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("FinalFile").Select
Range("A" & j).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'update counters'
i = i + 1
j = j + LastRow
'end of loop condition'
Sheets("Names").Select
Loop Until IsEmpty(Cells(i, 1))
End Sub
Here are some tips how to improve your code. I am not going into the issues I mentioned in my comment on the original question but just concentrate on specific parts of the code:
Remove Selections. The general pattern is instead of
something.Select
Selection.Dosomenthing
you use
something.Dosomething
In your case:
Sheets("Names").Select
Range("A" & i).Select
Selection.Copy
Sheets("Variables").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
becomes
Sheets("Names").Range("A" & i).Copy
Sheets("Variables").Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Use variables to reference your sheets like this:
Dim nameSheet as Worksheet
Dim varSheet as Worksheet
Dim finalSheet as Worksheet
Set nameSheet = Sheets("Names")
Set varSheet = Sheets("Variables")
Set finalSheet = Sheets("FinalFile")
Now you can use
finalSheet.Range(...).Pastespecial ...
and use Set finalSheet = Sheets("FinalFile2") once you run out of space
Don't copy cells next to each other one by one. You are copying cell Ai to A2 then Bi to B2. Just copy the range Ai:Ki to A2:K2 (although I don't see the point of this)
Don't use Copy if you don't need to. Instead of
someRange.Copy
someOtherRange.PasteSpecial Paste:=xlPasteValues
you can use
someOtherRange.Value = someRange.Value
(make sure the sizes are the same)
Disable Screenupdating using Application.Screenupdating = False (set it to True after you're done) when you're doing a lot of insertions. It can speed up a macro a lot.
As to your actual question, do as Tom suggests, add
If j > 1048576 Then
j = 2
Set finalSheet = Sheets("FinalFile2") 'maybe create the new sheet at this point
End If
You can add
j = j + lastRow
If j = 1048576 Then j = 2
BUT you should definitely clean up this code. .selections are a really slow way to do stuff like this. Look into this and try to avoid .Copy & .Paste. Just set your target cells to the values of your source with an =. This also saves a lot of time.
Edit: And definitely take a look at the link posted by #arcadeprecinct
I have a booking system (plain drop down list feeding into VLOOKUP fields). I want to be able to copy the information across and I can do this easily. The problem is that I want the sheet to allow multiple bookings and every time one booking is done to allow a second one to be done. At the moment it just rewrites the previous booking, it won't move down the available cells!
Below is the code used, I know it could be neater but I am looking as to why it doesn't work. I have an error displaying on the With section 424 it comes up with and usually complains about UsedRange.
Sub Bookingtry()
'
' Bookingtry Macro
'
' Keyboard Shortcut: Ctrl+h
'
Range("A2").Select
Sheets("Booking Form").Select
Range("B2").Select
Selection.Copy
Sheets("Booking sheet").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B2").Select
Sheets("Booking Form").Select
Range("B4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Booking sheet").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("C2").Select
Sheets("Booking Form").Select
Range("B6").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Booking sheet").Select
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D2").Select
Sheets("Booking Form").Select
Range("B8").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Booking sheet").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("E2").Select
Sheets("Booking Form").Select
Range("B10").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Booking sheet").Select
Range("E2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Booking Form").Select
Range("B12").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Booking sheet").Select
Range("F2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("G2").Select
Sheets("Booking Form").Select
Range("B14").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Booking sheet").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
With Sheets("Booking sheet").Cells(UsedRange.Columns(1).Rows.Count + 1, 1).Paste
End With
End Sub
I clean you code to see what you were trying to do, I guess that I'm ok for the first part.
But for your last "line" (the With with UsedRange), I don't really get what you are trying to paste... Everything else was already pasted. Anyway, I corrected the syntax of that last part too so that you can use it.
Give this a look :
Sub Bookingtry()
' Keyboard Shortcut: Ctrl+h
Dim FirstEmptyRow As Long, _
WsBF As Worksheet, _
WsBS As Worksheet
Set WsBF = ThisWorkbook.Sheets("Booking Form")
Set WsBS = ThisWorkbook.Sheets("Booking sheet")
FirstEmptyRow = WsBS.Range("A" & WsBS.Rows.Count).End(xlUp).Row + 1
WsBF.Range("B2").Copy
WsBS.Range("A" & FirstEmptyRow).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
WsBF.Range("B4").Copy
WsBS.Range("B" & FirstEmptyRow).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
WsBF.Range("B6").Copy
WsBS.Range("C" & FirstEmptyRow).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
WsBF.Range("B8").Copy
WsBS.Range("D" & FirstEmptyRow).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
WsBF.Range("B10").Copy
WsBS.Range("E" & FirstEmptyRow).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
WsBF.Range("B12").Copy
WsBS.Range("F" & FirstEmptyRow).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
WsBF.Range("B14").Copy
WsBS.Range("G" & FirstEmptyRow).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
I want to copy a defined number (lets say 10) of rows from one sheet ("Data") and paste it in another sheet ("Input). This will cause a bunch of stuff to calculate. Then I want to copy said calculated data (6 rows) from ("Input") to ("Data") and paste in a results table. THen I would repeat this a defined number of times for a certain number of columns (lets say 10).
I tried writing the code but it has literally been years since I have written code.
I used the Record Marco thing and got this:
Sub Macro2()
'
' Macro2 Macro
'
'
Range("C5:C14").Select
Selection.Copy
Sheets("Input").Select
Range("C5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("P12:P19").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Data").Select
Range("C22").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D5:D14").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Input").Select
Range("C5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("P12:P19").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Data").Select
Range("D22").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("G16").Select
End Sub
I hope this makes sense
Sub Macro2()
Const NUM_TIMES As Long = 10
Dim shtInput As Worksheet, shtData As Worksheet
Dim rngCopy As Range, i As Long
Set shtInput = Sheets("Input")
Set shtData = Sheets("Data")
Set rngCopy = shtData.Range("C5:C15")
For i = 1 To NUM_TIMES
With shtInput
.Range("C5").Resize(rngCopy.Rows.Count, 1).Value = rngCopy.Value
.Calculate
rngCopy(1).Offset(17, 0).Resize(8, 1).Value = .Range("P12:P19").Value
End With
Set rngCopy = rngCopy.Offset(0, 1)
Next i
End Sub