Copying specific colums into another file [VBA - excel

i have the following problem. I want to write a Macro, that copies three specific columns from a file "Rest.xlsx" into the original file "Schweben.xlsm". Both files are attached.
I already have the following code, which copies specific columns within the original file "Schweben.xlsm" from the table1 to a new created table2. Now i also want the macro to copy the columns K,H,D form Rest.xlsx to table2 within the "Schweben.xlsm" file into the new columns F,G,J (in that specific order). Since the files change daily, I want the macro to recognize the different lengths of the columns and always recognize all cells within the column, even if it is sometimes longer.
Sub CopyRowE()
Dim LastRowE As Long
Dim LastRowH As Long
Dim LastDataRow As Long
Dim CopyData As Long
With Tabelle1
LastRowE = .Range("E9999").End(xlUp).Row
LastRowH = .Range("H9999").End(xlUp).Row
.Range("E2:E" & LastRowE).Copy
.Range("CA1").PasteSpecial
.Range("H2:H" & LastRowH).Copy
.Range("CB1").PasteSpecial
LastDataRow = .Range("CB999999").End(xlUp).Row
.Range("CA1:CB" & LastDataRow).Copy
Sheets.Add
ActiveSheet.Range("A1").PasteSpecial
.Range("CA1:CB" & LastDataRow).ClearContents
Tabelle1.Select
.Range("A1").Select
End With
End Sub
Thanks in advance

Here is a simplified approach to copy columns of data from one sheet to another. I've matched what you asked for as best as I could understand your needs and commented the code well, so you can follow it. The important part here is the creation of a sub procedue that named "copy_column" that actually doest he copying when supplied with a source and destination cell.
Sub copyRowE()
Dim new_sheet As Worksheet
Dim source As Range
Dim dest As Range
Dim rest_sheet As Worksheet
'this code assumes that the Rest.xlsx workbook is open, if not, correct the
'following line and remove the comment character (')
'workbooks.open("c:\full\path\to\Rest.xlsx")
' copy E from tabelle1 to column A on new sheet
Set new_sheet = ThisWorkbook.Sheets.Add
'give new_sheet a name
'new_sheet.name = "Consolidated"
copy_column tabelle1.Range("E2"), new_sheet.Range("A1")
'copy H from tabelle1to column B on new sheet
copy_column tabelle1.Range("h2"), new_sheet.Range("B1")
'copy from the first sheet in rest.xlsx
Set rest_sheet = Workbooks("Rest.xlsx").Worksheets(1)
'OR copy from a particular sheet in Rest.xlsx
'Set rest_sheet = Workbooks("Rest.xlsx").Worksheets("Sheet1")
'copy column K from rest to column F on the new sheet
copy_column rest_sheet.Range("K2"), new_sheet.Range("F1")
'copy column H from rest to column G on the new sheet
copy_column rest_sheet.Range("H2"), new_sheet.Range("G1")
'copy column D from rest to column J on the new sheet
copy_column rest_sheet.Range("D2"), new_sheet.Range("J1")
End Sub
Sub copy_column(top_cell_in_source_column As Range, dest_cell As Range)
' copies data starting at top_cell_in_source_column and taking all data below it
' and pastes it beginning at dest_cell. The source and destination can be in
' different worksheets or even in different workbooks
Dim source_sheet As Worksheet
Dim source_col As Long
Set source_sheet = top_cell_in_source_column.Parent
source_col = top_cell_in_source_column.Column
Range(top_cell_in_source_column, source_sheet.Cells(source_sheet.Rows.Count, source_col).End(xlUp)).Copy dest_cell
End Sub

Related

Add rows before pasting data in a new sheet (between specific cells)

I have a sheet with data and I want to copy its data to another sheet. That's simple, but the problem is, I have to copy that selection to a range between two cells that is set, so if I add another row with data in the first sheet then when the macro runs, the data will overwrite the cells below the limit. How do I make it that if I add a row in the first sheet, before the macro pastes the data in the other sheet another row or a number of rows will be created to avoid the limit below being overwritten?
For example, if the number of rows between two cells is 5 and the range I need to paste is 7, then, prior to pasting the data, the macro creates two more rows.
Thank you
Calculate the difference and add rows if required
Option Explicit
Sub CopyInsert()
Dim rngSource As Range
Set rngSource = Selection ' range to copy from
Const SHEET_TARGET = "Sheet2"
Const RNG_TARGET = "C12:C16"
Dim wb As Workbook, wsTarget As Worksheet
Dim rngTarget As Range, n As Long
Set wb = ThisWorkbook
Set wsTarget = wb.Sheets(SHEET_TARGET)
Set rngTarget = wsTarget.Range(RNG_TARGET)
' insert new ones
n = rngSource.Rows.Count - rngTarget.Rows.Count
If n > 0 Then
rngTarget.Rows("2:" & n + 1).EntireRow.Insert
End If
rngSource.Copy rngTarget.Cells(1, 1)
End Sub

Copy and Paste a Range of Cells to another sheet if a cell outside the range =Resolved then delete the row

I currently have multiple sheets for storing records of payments (things to be Pay and CantPay). I am trying to write a macro that will copy and paste Cells A:M on every row where column T = "Resolved" on the CantPay sheet (where the next empty row is the next row where "a" & row-number = blank) to the "Pay" sheet.
Within the sheet which i want to copy from there is data in columns A:T but N:T are not needed once the problem is resolved. So once i have copy and pasted the data within cells A:M i want to just delete the entire row. I have written some code from what i knew and looking online which isn't working. Any help would be much appreciated.
Thanks
I have tried recording a macro and writing my own but it seems the macro i have wrote is deleting row 1 which is where all my column headers are stored.
Sub MoveToPay()
Dim CantPay As Worksheet: Set CopySheet = Sheets("Can't Pay")
Dim ReadyToPay As Worksheet: Set PasteSheet = Sheets("£ Pay")
Dim lr As Long
Dim S As String
Application.ScreenUpdating = False
Columns(20).AutoFilter 1, "Resolved"
With Range("a2", Range("M" & Rows.Count).End(3))
.Copy PasteSheet.Cells(Rows.Count, 1).End(3).Offset(1)
.EntireRow.Delete
End With
Columns(20).AutoFilter
Application.ScreenUpdating = True
End Sub

Copy range to the bottom of another sheet

I am writing a macro that loops through a "source" sheet and for each value in column A, copy a range from template sheet to a destination sheet. After the template range is copied, I need to change a few values in destination sheet based on the source sheet value. Right now I am trying to get the copy working. The copy is failing with error 1004 'The information cannot be pasted because the Copy area and the paste area are not the same size.'
Sub CopyRangeFromOneSheetToAnother()
Dim iLastRow As Long
Dim wb As Workbook
Dim shtSource As Worksheet
Dim shtTemplate As Worksheet
Dim shtDest As Worksheet
Dim sResourceName
Dim rngCalcTemplate As Range
Set wb = ThisWorkbook
Set shtSource = wb.Sheets(1)
Set shtTemplate = wb.Sheets("res_tpl")
Set shtDest = wb.Sheets.Add
'--set range for copying. Hard-coded for now would be nice if it would auto shrink/expand
Set rngCalcTemplate = shtTemplate.Range("A2:M7")
'Find the last row (in column A) with data.
iLastRow = shtSource.Range("A:A").Find("*", searchdirection:=xlPrevious).Row
'--loop through source sheet and copy template range to dest for each
For iSourceSheetRow = 2 To iLastRow
sResourceName = shtSource.Cells(iSourceSheetRow, 1)
rngCalcTemplate.Copy shtDest.Range("A" & Rows.Count).End(xlDown)
Next
End Sub
The problem is with the following line of your code:
rngCalcTemplate.Copy shtDest.Range("A" & Rows.Count).End(xlDown)
If you place your cursor at the very last cell in column A (i.e. at "A" & Rows.Count, possibly A1048576) and then press Ctrl-Down, you are still at the very last cell in column A.
If you then try to paste 6 rows of information starting at that cell, there won't be room to do so - there is only one row of "pastable" area to use.
You are probably wanting to find the row following the last used cell in that column, so your code should be:
rngCalcTemplate.Copy shtDest.Range("A" & shtDest.Rows.Count).End(xlUp).Offset(1, 0)

Setting value using filtered data

I'm trying to open a sheet (Archive) from my inventory sheet, filter the data in the second sheet and then copy the filtered data to a sheet on the inventory. Everything is working except that the filtered data only copies the data from rows in the first contiguous range. My code is as follows
Dim LastRow As Long
Dim nOoFrOWS As Long
Dim oSht As Worksheet
Workbooks.Open ("C:\Inventory\Archive.xlsm") '<- at opening a workbook it becomes the active one
Set oSht = ActiveWorkbook.Worksheets("Archive") '<-- set the destination worksheet in the activeworkbook
With ActiveSheet
.ListObjects("Archive").Range.AutoFilter Field:=12, Criteria1:=mOrder
nOoFrOWS = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1 '# of rows in Inventory
End With
Unload Me
ThisWorkbook.Sheets("RAM").Range("A2:K" & nOoFrOWS).Value = oSht.Range("Archive[[QTY]:[RTK]]").SpecialCells(xlCellTypeVisible).Cells.Value
oSht.Parent.Close False
What am I doing wrong?
edit: I don't know if it is pertinent, but the range in the archive (from which I am copying) is not the entire table. I have more rows, but These are all I need for this application.
Also, is there a way to do this without the clipboard by using .value or am I stuck with using the copy paste method?
As your working with a table you can copy the visible cells in the databodyrange.
No need to activate or select anything - just work with the referenced files & sheets.
Sub Test()
Dim wrkBk As Workbook
Dim mOrder As Long
mOrder = 5
'You can reference the workbook without it being active.
Set wrkBk = Workbooks.Open("C:\Inventory\Archive.xlsm")
With wrkBk.Worksheets("Archive").ListObjects("Archive")
.Range.AutoFilter Field:=12, Criteria1:=mOrder
'Copy the DataBodyRange (Range would include the headers).
.DataBodyRange.Resize(, 11).SpecialCells(xlVisible).Copy Destination:=ThisWorkbook.Worksheets("RAM").Range("A2")
End With
End Sub

listing text-based data from column C in multiple sheets into a single column in a master sheet in excel

I have a workbook filled with text-based data on several different sheets. All the sheets use the same headings, but have different text in the columns. I would like to be able to list the information contained in the column C from all of the sheets in a single column in a new sheet.
Is there a way to get all of that data into a single column without having to copy and past from nearly 100 different sheets?
Using VBA, here is a solution that works. You just need to insert a module into your workbook and run this. F11 > Insert > Module. Copy and paste this code, and hit play.
This will create a new worksheet with whatever name you define under newSheet. Then take the contents of EVERY worksheet Row C (after header), no matter how many you have or what their name is, and add them to the new one. I could see a problem if you exceed 1,000,000 rows.. Other than that, if there are any sheets you DON'T want to perform this on, we would add them as exceptions specifically by name in the If statement.
TESTED:
Private Sub CopyAllSheetsCol()
Dim WS As Worksheet
Dim newSheet As String
Dim lastRow As Long 'Last Row on source Sheet
Dim tRow As Long 'target row
newSheet = "Compiled" 'name can be changed here
Sheets.Add.Name = newSheet
tRow = 2 'Set the target Row to 2, Set the Header Row manually
For Each WS In ActiveWorkbook.Worksheets
If WS.Name <> newSheet Then 'Making sure we are only working with pre-existing sheets
lastRow = Sheets(WS.Name).Range("C2").End(xlDown).Row 'get last row of Column C on each Worksheet
For r = 2 To lastRow 'Loop through all rows skipping header
Sheets(newSheet).Cells(tRow, "C") = Sheets(WS.Name).Cells(r, "C") 'Copy to newSheet
tRow = tRow + 1 'Increment target row by 1
Next r
End If
Next
End Sub
edit: touched up explanation

Resources