I am writing VBA code in Excel to copy formulas from the last row of data to the row below it and then copying that last row (now second-to-last row) and paste as values in it's place. I would like to do this for multiple sheets. The problem is that after it works properly for the first sheet, it errors out on the next sheet (and presumably the rest of them).
The code works for the first worksheet but when it moves to the next sheet, Excel gives me a "Run-time error '1004': No cells were found" error message". When I debug the error, the 2nd line in the 3rd paragraph below is what gives me the problem. What do I have to do to allow this code to work for multiple worksheets in the same workbook?
Sheets("BrentSkew").Select
NextFree = Range("A2:A" &
Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("A" & NextFree - 1).Select
Range(Selection, Selection.End(xlToRight)).Select
Application.CutCopyMode = False
Selection.Copy
NextFree = Range("A2:A" &
Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("A" & NextFree).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Sheets("BrentSkew").Select
NextFree = Range("A2:A" &
Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("A" & NextFree - 2).Select
Range(Selection, Selection.End(xlToRight)).Select
Application.CutCopyMode = False
Selection.Copy
NextFree = Range("A2:A" &
Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("A" & NextFree - 2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks
_
:=False, Transpose:=False
Sheets("LLSSkew").Select
'the line below is the problem
NextFree = Range("A2:A" &
Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("A" & NextFree - 1).Select
Range(Selection, Selection.End(xlToRight)).Select
Application.CutCopyMode = False
Selection.Copy
NextFree = Range("A2:A" &
Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("A" & NextFree).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Sheets("LLSSkew").Select
NextFree = Range("A2:A" &
Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("A" & NextFree - 2).Select
Range(Selection, Selection.End(xlToRight)).Select
Application.CutCopyMode = False
Selection.Copy
NextFree = Range("A2:A" &
Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("A" & NextFree - 2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks
_
:=False, Transpose:=False
Related
I'm getting a compile error when I try to run this code:
(Only a section of it is shown here because only one bit is highlighted in the debugger)
The bolded bit is the part which is giving me problems.
The references I have active are:
Visual Basic for Applications
Microsoft Excel 16.0 Object Library
Microsoft ActiveX Data Objects 6.1 Library
OLE Automation
Microsoft Office 16.0 Object Library
We're running in Word and Excel 2016.
Any help would be greatly appreciated.
'This will delete any rows that have findings that took place prior to the date that was previously entered.
For CellNum = TotalRowNum To 1 Step -1
If Cells(CellNum, 10) < backtolong Then Rows(CellNum).Delete
Next
CurrentRowNum = Cells(Rows.Count, 2).End(xlUp).Row
'This sorts the findings remaining based on alphabetical order, to make the copy over to word easier as A is first... etc.
Range("A1:J" & CurrentRowNum).Sort key1:=Range("I1:I" & CurrentRowNum), order1:=xlAscending, Header:=xlNo
Dim lastrow As Long
lastrow = ThisWorkbook.Sheets("Pre-Transfer Table").Range("A1", ThisWorkbook.Sheets("Pre-Transfer Table").Range("A1").End(xlDown)).Rows.Count
'Designates the file that the data will be transferred to.
Dim stWordDocument As String
stWordDocument = InputBox("Please enter the name of the word file you have created for this report (Include '.doc').")
**Dim wdApp As Word.Application**
Dim wdDoc As Word.Document
Dim wdCell As Word.Cell
Dim i As Long
Dim j As Long
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim vaData As Variant
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Pre-Transfer Table")
'Creates a 2D array populated by all of the finding critera
ReDim vaData(1 To lastrow, 1 To 8)
With wsSheet
vaData = .Range("A1:H" & lastrow)
End With
Set wdApp = New Word.Application
'Opens the word document by accessing the same folder the workbook is stored in
Set wdDoc = wdApp.Documents.Open(wbBook.Path & "\" & stWordDocument)
'Populates the tables with the corresponding criteria
k = 4
For i = 1 To lastrow
j = 0
For Each wdCell In wdDoc.Tables(k).Columns(2).Cells
j = j + 1
wdCell.Range.Text = vaData(i, j)
Next wdCell
k = k + 1
Next i
'Deletes the sheet used for sorting, as the code cannot run again unless this sheet is removed or the name of it is changed.
ThisWorkbook.Sheets("Pre-Transfer Table").Delete
With wdDoc
.Save
.Close
End With
wdApp.Quit
'Frees up memory by clearing these variables.
Set wdDoc = Nothing
Set wdApp = Nothing
MsgBox "Your report has been generated.", vbInformation
End Sub
This section is giving me the error:
Sheets("Other Findings").Select
**Range("Table2[ASSIGNED" & Chr(10) & "TO]").Select**
Selection.Copy
Sheets("Pre-Transfer Table").Select
Range("E" & FindingRowNum + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks
:=False, Transpose:=False
In the code section
'Creates the sheet where the resorting of data is done. All of the relevant columns are copied over to this table.
Sheets.Add
ActiveSheet.Name = "Pre-Transfer Table"
Sheets("Risk Ranked Findings").Select
Range("Table1[DETAILS]").Select
Selection.Copy
Sheets("Pre-Transfer Table").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Risk Ranked Findings").Select
Range("Table1[LOCATION]").Select
Application.CutCopyMode = False
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Sheets("Pre-Transfer Table").Select
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Risk Ranked Findings").Select
Application.CutCopyMode = False
Range("Table1[TYPE]").Select
Selection.Copy
Sheets("Pre-Transfer Table").Select
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Risk Ranked Findings").Select
Range("Table1[RECOMMENDED" & Chr(10) & "ACTION]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Pre-Transfer Table").Select
Range("D1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Risk Ranked Findings").Select
Range("Table1[DUE DATE]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Pre-Transfer Table").Select
Range("E1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = True
Selection.NumberFormat = "m/d/yyyy"
Sheets("Risk Ranked Findings").Select
Range("Table1[ASSIGNED" & Chr(10) & "TO]").Select
Selection.Copy
Sheets("Pre-Transfer Table").Select
Range("F1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Risk Ranked Findings").Select
Range("Table1[RISK]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Pre-Transfer Table").Select
Range("I1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Risk Ranked Findings").Select
Range("Table1[FINDING" & Chr(10) & "DATE]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Pre-Transfer Table").Select
Range("J1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Sheets("Risk Ranked Findings").Select
Range("S2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Pre-Transfer Table").Select
Range("M1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
FindingRowNum = Range("M1")
'This area is where the "Other Findings" are sorted and transferred. There is probably some redundancy here so if anything is to be cleaned up it is
'most likely this.
Dim OtherRowNum As Long
Dim TotalRowNum As Long
Dim CurrentRowNum As Long
Sheets("Other Findings").Select
Range("O2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Pre-Transfer Table").Select
Range("M2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
OtherRowNum = Range("M2")
TotalRowNum = OtherRowNum + FindingRowNum
Sheets("Other Findings").Select
Range("Table2[DETAILS]").Select
Selection.Copy
Sheets("Pre-Transfer Table").Select
Range("A" & FindingRowNum + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Other Findings").Select
Range("Table2[LOCATION]").Select
Application.CutCopyMode = False
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Sheets("Pre-Transfer Table").Select
Range("B" & FindingRowNum + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Other Findings").Select
Application.CutCopyMode = False
Range("Table2[RECOMMENDED" & Chr(10) & "Action]").Select
Selection.Copy
Sheets("Pre-Transfer Table").Select
Range("C" & FindingRowNum + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Other Findings").Select
Range("Table2[DUE DATE]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Pre-Transfer Table").Select
Range("D" & FindingRowNum + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = True
Selection.NumberFormat = "m/d/yyyy"
Sheets("Other Findings").Select
Range("Table2[ASSIGNED" & Chr(10) & "TO]").Select
Selection.Copy
Sheets("Pre-Transfer Table").Select
Range("E" & FindingRowNum + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Other Findings").Select
Range("Table2[TYPE]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Pre-Transfer Table").Select
Range("I" & FindingRowNum + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Other Findings").Select
Range("Table2[FINDING" & Chr(10) & "DATE]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Pre-Transfer Table").Select
Range("J" & FindingRowNum + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Sub Load()
'
' Load Evaluation Macro
'
'
Dim zelda As Integer
zelda = Lookup()
Sheets("RawData").Select
Range("A" & zelda).Select (highlighted row in yellow)
Selection.Copy
Sheets("Evaluation Form").Select
Range("D1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("RawData").Select
Range("C" & zelda & " :G" & zelda).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Evaluation Form").Select
Range("D3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("RawData").Select
Range("J" & zelda & " :U" & zelda).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Evaluation Form").Select
Range("C10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("RawData").Select
Range("V" & zelda & " :X" & zelda).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Evaluation Form").Select
Range("C26").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("RawData").Select
Range("X" & zelda & " :Y" & zelda).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Evaluation Form").Select
Range("C33").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
'--------------------Load Comments------------------------------------------
Sheets("RawData").Select
Range("AA" & zelda & " :AL" & zelda).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Evaluation Form").Select
Range("E9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("RawData").Select
Range("AM" & zelda & " :AO" & zelda).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Evaluation Form").Select
Range("E19").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("RawData").Select
Range("AP" & zelda & " :AQ" & zelda).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Evaluation Form").Select
Range("E24").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
'----------------------------------------------------------------------------
Range("E1").Select
End Sub
Function LookUp() As Integer
Dim NameAgent As String
Dim EvalID As Integer
Dim nrow As Long
Dim ncol As Long
Dim i As Long
' Look Up Values ---------------------
Sheets("Evaluation Form").Select
NameAgent = Range("D1").Value
EvalID = Range("D6").Value
'------------------------------------
Sheets("RawData").Select
nrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To nrow
If NameAgent = Cells(i, 1).Value Then
If Cells(i, 4).Value = EvalID Then
LookUp = i
End If
Else
End If
Next i
End Function
I have used this same macro in numerous workbooks and specifically this one is not running correctly.
Any help will be greatly appreciated.
I'm really new at maccros.
I've made one using the auto recording, but I can't seem to use it to the selected row only, it keeps doing it on the same row as the record.
I really need your help to solve it, and help me having a better understanding on how maccros actually works
My macro is as follow:
Sub COPIERVALEURS()
'
' COPIERVALEURS Macro
'
' Touche de raccourci du clavier: Ctrl+Shift+V
'
Range("A34:H34").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("M34:N34").Select
Application.CutCopyMode = False
Selection.Copy
Range("K34").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("S34:T34").Select
Application.CutCopyMode = False
Selection.Copy
Range("Q34").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("Y34:Z34").Select
Application.CutCopyMode = False
Selection.Copy
Range("W34").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("AE34:AF34").Select
Application.CutCopyMode = False
Selection.Copy
Range("AC34").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.SmallScroll ToRight:=5
Range("AI34:AJ34").Select
Application.CutCopyMode = False
Selection.Copy
Range("AG34").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("AK34").Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
I try to understand your logic to help you as much as i can. Select the row you want this code to take action, import a break point in the With line, execute and debug the code to see if its fits your requirements. In order to select a line press on the number of each line on your left.
Code:
Option Explicit
Sub test()
Dim RowNo As Long
With ThisWorkbook.Worksheets("Sheet1")
RowNo = Selection.Row '<- Here you get the row number you have select
.Range("M" & RowNo & ":N" & RowNo).Copy '<- Copy range M:N of the RowNo you have selct
.Range("K" & RowNo).PasteSpecial Paste:=xlPasteValues '<- Paste in Column K row the one tou have select
.Range("S" & RowNo & ":T" & RowNo).Copy
.Range("Q" & RowNo).PasteSpecial Paste:=xlPasteValues
.Range("Y" & RowNo & ":Z" & RowNo).Copy
.Range("W" & RowNo).PasteSpecial Paste:=xlPasteValues
.Range("AE" & RowNo & ":AF" & RowNo).Copy
.Range("AC" & RowNo).PasteSpecial Paste:=xlPasteValues
.Range("AI" & RowNo & ":AJ" & RowNo).Copy
.Range("AG" & RowNo).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End With
End Sub
Thanks Error 1004, It helped me a lot, the final code is now as below, and work perfectly, thanks to you:
Option Explicit
Sub COPIERVALEURS()
' COPIERVALEURS Macro
' Touche de raccourci du clavier: Ctrl+Shift+V
Dim RowNo As Long
With ThisWorkbook.Worksheets("PAQ")
RowNo = Selection.Row '<- Here you get the row number you have select
.Range("A" & RowNo & ":H" & RowNo).Copy
.Range("A" & RowNo & ":H" & RowNo).PasteSpecial Paste:=xlPasteValues
.Range("M" & RowNo & ":N" & RowNo).Copy
.Range("K" & RowNo).PasteSpecial Paste:=xlPasteValues
.Range("S" & RowNo & ":T" & RowNo).Copy
.Range("Q" & RowNo).PasteSpecial Paste:=xlPasteValues
.Range("Y" & RowNo & ":Z" & RowNo).Copy
.Range("W" & RowNo).PasteSpecial Paste:=xlPasteValues
.Range("AE" & RowNo & ":AF" & RowNo).Copy
.Range("AC" & RowNo).PasteSpecial Paste:=xlPasteValues
ActiveWindow.SmallScroll ToRight:=5
.Range("AI" & RowNo & ":AJ" & RowNo).Copy
.Range("AG" & RowNo).PasteSpecial Paste:=xlPasteValues
.Range("AK" & RowNo).Copy
.Range("AK" & RowNo).PasteSpecial Paste:=xlPasteValues
End With
End Sub
I've made a VBA for a button in Excel for Mac that is supposed to copy the content of a few selected cells on one tab and paste it (as values) on the first available cell in an assigned row on a different tab.
This is the first time I've ever had a go at making this, so I probably didn't do it as efficient as possible, but it works.
The problem is that it only works on Mac. My co-workers that I've made it for uses PC. Can I convert the code to work on Excel for PC?
Edit: I should have been more explicit into what the problem actually is (thanks #KenWhite).
So here's what happened:
I created the file and the VBA.
I saved my file and attatched it to an email
my co-worker saved it and opened it up
When she pressed the button she got an error "Indexet är utanför intervall". My best translation for this is Index out of Range (but I'm not completely sure)
I suspected that it had to do with Mac -> PC, but some have pointed out that there should be no difference. I realize that the named on the sheets and that the data needs to be in the exact same spot - but that shouldn't be an issue in this case.
Edit 2: It seems to be a problem with special characters. the "ä" and "ö" used in the sheet names where changed in to "š" and "¨" in the VBA code on their end. I can't test it right now, but my guess is that the code will work if I either manually change the characters in the code or make sure to use sheet names without special characters.
If I should/could add additional information, let me know and I'll make another edit.
Thank you everyone.
Sub Generera()
'
' Generera Makro
'
'
Range("B1").Select
Selection.Copy
Sheets("Utveckling över tid").Select
BMaxRows = Cells(Rows.Count, "B").End(xlUp).Row
Range("B" & BMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("veckoräckvidd").Select
Range("B2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Utveckling över tid").Select
CMaxRows = Cells(Rows.Count, "C").End(xlUp).Row
Range("C" & CMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("veckoräckvidd").Select
Range("B3").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Utveckling över tid").Select
DMaxRows = Cells(Rows.Count, "D").End(xlUp).Row
Range("D" & DMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("veckoräckvidd").Select
Range("B4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Utveckling över tid").Select
EMaxRows = Cells(Rows.Count, "E").End(xlUp).Row
Range("E" & EMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("veckoräckvidd").Select
Range("B6").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Utveckling över tid").Select
FMaxRows = Cells(Rows.Count, "F").End(xlUp).Row
Range("F" & FMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("veckoräckvidd").Select
Range("B7").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Utveckling över tid").Select
GMaxRows = Cells(Rows.Count, "G").End(xlUp).Row
Range("G" & GMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("veckoräckvidd").Select
Range("B8").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Utveckling över tid").Select
HMaxRows = Cells(Rows.Count, "H").End(xlUp).Row
Range("H" & HMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("veckoräckvidd").Select
Range("B9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("veckoräckvidd").Select
Range("B11").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Utveckling över tid").Select
IMaxRows = Cells(Rows.Count, "I").End(xlUp).Row
Range("I" & IMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("veckoräckvidd").Select
Range("B12").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Utveckling över tid").Select
JMaxRows = Cells(Rows.Count, "J").End(xlUp).Row
Range("J" & JMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
I believe this is a replacement for your current macro, so this might solve your problem.
Sub Generera()
Dim ws1 As Worksheet
Set ws1 = sheets("Utveckling över tid")
Dim ws2 As Worksheet
Set ws2 = sheets("veckoräckvidd")
Dim i As Long
For i = 2 To 10
Dim colLetter As String
colLetter = Split(Cells(1, i).Address, "$")(1)
ws1.Range(colLetter & ws1.Cells(rows.count, colLetter).End(xlUp).row + 1).value = ws2.Range("B" & i - 1).value
Next i
End Sub
Here are the steps I took to convert your original code to my shorter version:
Range("B1").Select
Selection.copy
sheets("Utveckling över tid").Select
BMaxRows = Cells(rows.count, "B").End(xlUp).row
Range("B" & BMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Stopped using .Select, and started using direct Range().value transferring instead of .copy and .pastespecial so that I dont have to juggle cutcopymode and because you're not doing anything special, just copying the values only.
BMaxRows = sheets("veckoräckvidd").Cells(rows.count, "B").End(xlUp).row
sheets("veckoräckvidd").Range("B" & BMaxRows + 1).value = _
sheets("Utveckling över tid").Range("B1").value
Include the statement for BMaxRows inside of the range itself for eventual simplicity.
sheets("veckoräckvidd").Range("B" & sheets("veckoräckvidd").Cells(rows.count, "B").End(xlUp).row + 1).value = _
sheets("Utveckling över tid").Range("B1").value
Use Worksheet variables to shorten every time that I need to refer to one of the sheet names.
ws2.Range("B" & ws2.Cells(rows.count, "B").End(xlUp).row + 1).value = _
ws1.Range("B1").value
And to convert it to a loop you can compare a couple of the converted operations side by side to see what changes every instance. In this case it's the column letter for ws2 and the row number in ws1.
ws2.Range("B" & ws2.Cells(rows.count, "B").End(xlUp).row + 1).value = ws1.Range("B1").value
ws2.Range("C" & ws2.Cells(rows.count, "C").End(xlUp).row + 1).value = ws1.Range("B2").value
ws2.Range("D" & ws2.Cells(rows.count, "D").End(xlUp).row + 1).value = ws1.Range("B3").value
I am trying to run a macro that copy three tables from different worksheets and paste it together in a new worksheet.
The number of rows in the tables are not always the same. Therefore, I need a macro with a 'dynamic' "LastRow" parameter so that every time I update one single table the result of the macro is updated.
I tried to run this macro:^
Dim lastRow As Long
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Discussed Files").Select
Range("Table1[#Headers]").Select
Selection.Copy
Sheets("All data").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Discussed Files").Select
Range("Table1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("All data").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Files within 3 Days").Select
Range("Table3").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("All data").Select
Range("A" & lastRow).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Files 10.04.17").Select
Range("Table5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("All data").Select
Range("A" & lastRow).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$Y$" & lastRow), , xlYes).Name = _
"Table14"
Range("Table14[#All]").Select
ActiveSheet.ListObjects("Table14").TableStyle = "TableStyleMedium2"
I cannot understand exactly what the macro is doing. It ends up woth a table having number of rows equal to first sheet but data inside the table are 'randomly' taken from the other sheets.
Moreover, the selection to make the result a table is not working properly.
As per comment above (have also removed unnecessary Selects)
Sub x()
Dim lastRow As Long
With Sheets("All data")
Sheets("Discussed Files").Range("Table1[#All]").Copy
.Range("A1").PasteSpecial Paste:=xlPasteValues
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
Sheets("Files within 3 Days").Range("Table3").Copy
.Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
Sheets("Files 10.04.17").Range("Table5").Copy
.Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.ListObjects.Add(xlSrcRange, .Range("$A$1:$Y$" & lastRow), , xlYes).Name = "Table14"
.ListObjects("Table14").TableStyle = "TableStyleMedium2"
End With
End Sub
You don't update lastRow between steps, so you are basically pasting them one over another into same spot because the lastRow does not update after you paste one of your tables, it retains the same value from the beginning of your code in each:
Range("A" & lastRow).Select
Selection.PasteSpecial
Also, this code will return last row with data in it so if you are pasting into clean sheet, you are pasting all tables into the same spot:
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
EDIT:
Dim lastRow As Long
lastRow = Sheets("All data").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Discussed Files").Range("Table1[#All]").Select
Selection.Copy
Sheets("All data").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
lastRow = Sheets("All data").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Files within 3 Days").Range("Table3").Select
Selection.Copy
Sheets("All data").Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
lastRow = Sheets("All data").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Files 10.04.17").Range("Table5").Select
Selection.Copy
Sheets("All data").Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
lastRow = Sheets("All data").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("All data").ListObjects.Add(xlSrcRange, Range("$A$1:$Y$" & lastRow), , xlYes).Name = _
"Table14"
Range("Table14[#All]").Select
Sheets("All data").ListObjects("Table14").TableStyle = "TableStyleMedium2"