How to copy columns from one worksheet to another on excel with VBA? - excel

I am trying to copy certain column from one worksheet to another but when I apply my code, I get no errors but also no results. I get blank paper. I applied this methodolgy on copying a certain row and it was copied to another worksheet perfectly.
This is regarding the successful attempt to copy row.
The code works just fine:
Sub skdks()
Dim OSheet As Variant
Dim NSheet As Variant
Dim i As Integer
Dim LRow As Integer
Dim NSLRow As Integer
OSheet = "Tabelle3" 'Old Sheet Name
NSheet = "Tabelle5" 'New Sheet Name
LRow = Sheets(OSheet).Cells(Rows.Count, 1).End(xlUp).row 'Last Row in Old Sheet
Sheets(OSheet).Activate
For i = 2 To LRow
'Finds last row in the New Sheet
If Sheets(NSheet).Cells(2, 1) = "" Then
NSLRow = 1
Else
NSLRow = Sheets(NSheet).Cells(Rows.Count, 1).End(xlUp).row
End If
'If cell has "certain # then..."
If Cells(i, 1).Value = Cells(13, 2).Value Then
Cells(i, 1).EntireRow.Copy
Sheets(NSheet).Cells(NSLRow + 1, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
Next i
End Sub
This little piece of code is the failed attempt to copy column to another worksheet.
Sub trial()
Dim OSheet As Variant
Dim NSheet As Variant
Dim j As Integer
Dim LColumn As Integer
Dim NSLColumn As Integer
OSheet = "Tabelle2" 'Old Sheet Name
NSheet = "Tabelle5" 'New Sheet Name
LColumn = Sheets(OSheet).Cells(1, Columns.Count).End(xlToLeft).Column 'Last Column in Old Sheet
Sheets(OSheet).Activate
For j = 2 To LColumn
'Finds last column in the New Sheet
If Sheets(NSheet).Cells(1, 2) = "" Then
NSLColumn = 1
Else
NSLColumn = Sheets(NSheet).Cells(1, Columns.Count).End(xlToLeft).Column
End If
'If cell has "certain # then..."
If Cells(2, j) = Cells(13, 2) Then
Cells(2, j).EntireColumn.Copy
Sheets(NSheet).Cells(2, 2).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
Next j
End Sub

....
'If cell has "certain # then..."
If Cells(2, j) = Cells(13, 2) Then
debug.Print Cells(2, j).Address; " = "; Cells(13, 2).Address; " ---- COPY"
debug.print Cells(2, j).EntireColumn.address; Cells(2, j).EntireColumn.cells.count
debug.Print Sheets(NSheet).Cells(2, 2).Address
Cells(2, j).EntireColumn.Copy
Sheets(NSheet).Cells(2, 2).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
....
With the line If Cells(2, j) = Cells(13, 2) Then you compare the different cells from row 2 (B2, C2, D2, ...) with the value of cell "B13". If the value is the same you copy this column to the new worksheet.
Is there any equal value in your data? If yes you should get an error message with your code.
You try to copy the values of an entire column to the range starting with "B2". Of cause there is not enough space for this.
=> Either you reduce the source range or you start the destination range on row 1!

To add to the paste destination size, if you really want to paste the entire column, you either need to start at the beginning of the column or choose the entire column. Also, I think you want to make the paste column increase with your NSLColumn
If Cells(2, j) = Cells(13, 2) Then
Cells(2, j).EntireColumn.Copy
Sheets(NSheet).Columns(NSLColumn + 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If

Related

copy, paste, transpose rows with pictures

I have a macro that copies and pastes rows from input sheet to output sheet. I find PRODUCT NAME and END DATE, then copy the whole row and transpose when pasting it. I am using transpose because I want to have vertical table.
I have a problem with images because I don't know how to copy them to proper cell so they match with Name and Date. I've managed to write a script that is copying and pasting images but it puts all of them in cell A1. When I want to add range to target_sheet.Paste I am getting vba method intersect of object _application failed error.
Below you can see how input and output sheets look.
Input sheet:
Expected output sheet (with only 3 columns) :
It is very important to know that 'input' sheet contains many products with names, prices and images and there is always a blank row between them. The number of images in each row can be different (from 1 to 25).
Sub copy_paste()
Dim Cell As Range
Dim src_rng As String
Dim LR As Long
Dim source_sheet As Worksheet
Dim target_sheet As Worksheet
Dim pic As Shape
'worksheet with source data
Set source_sheet = ThisWorkbook.Sheets("input")
'worksheet with newly created template
Set target_sheet = ThisWorkbook.Sheets("output")
'range of cells I want to check
src_rng = "A14:A26"
Application.ScreenUpdating = False
target_sheet.Cells.Delete
'copy paste, transpose product line rows
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("A10000").End(xlUp).Row + 1
If Cell.Value = "Name" Then
Cell.EntireRow.Copy
target_sheet.Range("A" & LR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End If
Next
'copy paste, transpose end line rows
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("B10000").End(xlUp).Row + 1
If Cell.Value = "Date" Then
Cell.EntireRow.Copy
target_sheet.Range("B" & LR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End If
Next
'copy paste image
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("C10000").End(xlUp).Row + 1
If Cell.Value = "Image" Then
For Each pic In source_sheet.Shapes
If Not Application.Intersect(pic.TopLeftCell, Range(src_rng)) Is Nothing Then
pic.CopyPicture
target_sheet.Paste
End If
Next pic
End If
Next
Application.ScreenUpdating = True
End Sub
Please, try the next code. It follows the logic deduced from your last question edit, respectively: the former "Name" becomes "Product Name", "Date" becomes "End Date" and the row keeping the pictures is the one below "Product Name" row. It is able to process two or three product names/pictures per group:
Sub copy_paste()
Dim Cell As Range, src_rng As String, LR As Long
Dim source_sheet As Worksheet, target_sheet As Worksheet
Dim pic As Shape, arrPAddr, rngTr As Range, k As Long
Dim cellRHeight As Range, nrShapesPerRange As Long 'to be 2 or 3
nrShapesPerRange = 2 'Choose here initial number of shapes per row (2 or 3)
'worksheet with source data
Set source_sheet = ThisWorkbook.Sheets("input")
'worksheet with newly created template
Set target_sheet = ThisWorkbook.Sheets("output")
'range of cells I want to check
src_rng = "A14:A26"
Application.ScreenUpdating = False
ReDim arrPAddr(1 To 2, 1 To source_sheet.Shapes.count): k = 1
target_sheet.cells.Delete: For Each pic In target_sheet.Shapes: pic.Delete: Next
'copy paste, transpose product line rows
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("A" & rows.count).End(xlUp).row + 1
If Cell.value = "Product Name" Then
source_sheet.Range(Cell.Offset(, 1), Cell.Offset(, 3)).Copy
Set rngTr = target_sheet.Range("A" & LR)
rngTr.PasteSpecial Paste:=xlAll, Transpose:=True
arrPAddr(1, k) = Cell.Offset(1, 1).Address
arrPAddr(2, k) = rngTr.Offset(, 2).Address: k = k + 1
arrPAddr(1, k) = Cell.Offset(1, 2).Address
arrPAddr(2, k) = rngTr.Offset(1, 2).Address: k = k + 1
If nrShapesPerRange = 3 Then
arrPAddr(1, k) = Cell.Offset(1, 3).Address
arrPAddr(2, k) = rngTr.Offset(2, 2).Address: k = k + 1
End If
If cellRHeight Is Nothing Then Set cellRHeight = Cell.Offset(1)
End If
LR = target_sheet.Range("B" & rows.count).End(xlUp).row + 1
If Cell.value = "End Date" Then
source_sheet.Range(Cell.Offset(, 1), Cell.Offset(, 3)).Copy
Set rngTr = target_sheet.Range("B" & LR)
rngTr.PasteSpecial Paste:=xlAll, Transpose:=True
End If
Next
ReDim Preserve arrPAddr(1 To 2, 1 To k - 1)
'Making the row height in target_sheet equal to source_sheet column with:
target_sheet.Range("2:" & LR + 3).EntireRow.RowHeight = source_sheet.Range("A16").EntireRow.RowHeight
target_sheet.Range("A:C").EntireColumn.AutoFit
target_sheet.Range("C1").EntireColumn.ColumnWidth = cellRHeight.EntireColumn.ColumnWidth
'copy paste image:
Dim i As Long
For Each pic In source_sheet.Shapes
For i = 1 To UBound(arrPAddr, 2)
If pic.TopLeftCell.Address = arrPAddr(1, i) Then
pic.Copy: target_sheet.Paste
With target_sheet.Shapes(target_sheet.Shapes.count)
.top = target_sheet.Range(arrPAddr(2, i)).top + (target_sheet.Range(arrPAddr(2, i)).RowHeight - pic.height) / 2
.left = target_sheet.Range(arrPAddr(2, i)).left
End With
Exit For
End If
Next i
Next
Application.ScreenUpdating = True
target_sheet.Activate
MsgBox "Ready..."
End Sub
Plese, test the code and send some feedback

VBA find decimals and copy

I am trying to find value that contain decimal point in the column F, then copy those row into another sheet.
I don't know how to find the value of decimal. If I set the Value = "1", it will work, it will copy the row that have number 1 in it to another sheet. Need some help
Sub SpecialCopy()
Dim targetSh As Worksheet
Set targetSh = ThisWorkbook.Worksheets("Error")
Dim i As Long
For i = 1 To Cells(Rows.Count, "F").End(xlUp).Row
If Cells(i, 6).Value = "." Then
Range(Cells(i, 2), Cells(i, 6)).Copy
Destination:=targetSh.Range("A" & targetSh.Cells _
(Rows.Count, "A").End(xlUp).Row + 1)
End If
Next i
End Sub

VBA codes for Excel- Find a cells value in another workbook and copy adjacent cell to the first workbook

I have a quick question; I have two workbooks, let's say wbk1 and wbk2; What I am trying to do is finding each cell value of a column in wbk1 in a specific column of wbk2 and return offset cell value from wbk2 to adjacent cell of the searched value in wbk1.
Is there any one who can help?
By the way, I could find following code if it helps;
'=================
Sub find1()
Dim Key
Dim Target
Dim Hnum
Dim Success
Dim wbk As Workbook
Dim Lastrow As Long
Dim one As Long
Success = False
Application.ScreenUpdating = False
strSecondFile = "C:\Soroush\08- Technical\03- Stock\Test\PL_Test_01\PL_Test_01.xlsm"
strFrthFile = "C:\Soroush\08- Technical\03- Stock\CNC_Test.xlsx"
'==
Sheets("sheet2").Select
Lastrow = ActiveSheet.UsedRange.Rows.Count
If Not IsEmpty(Cells(5, 9).Value) Then
Key = Cells(5, 9).Value
For i = 5 To Lastrow
' If Not IsEmpty(Cells(i, 9).Value) Then
' Key = Cells(i, 9).Value
Set wbk = Workbooks.Open(strFrthFile)
With wbk.Sheets("Sheet1")
Set Target = Columns(1).find(Key, LookIn:=xlValues)
If Not Target Is Nothing Then
ActiveCell.Select
Selection.Copy
Set wbk = Workbooks.Open(strSecondFile)
With wbk.Sheets("Sheet2")
Sheets("Sheet2").Select
Cells(i, 10).Select
ActiveCell.Paste
If Not IsEmpty(Cells(i + 1, 9).Value) Then
Key = Cells(i + 1, 9).Value
End If
End With
End If
End With
'End If
Next
End If
End Sub
'=========================================================================
But It does not work and I can't figure it out. I appreciate any comments on this macro.
Cheers
You can use INDEX and MATCH.
In this case, the value in cell E2 is matched against values in B2 to B6. This is then indexed against column C and the value in column C is returned.
*ignore the typo for "mammal"!

Inserting An "Array" between Rows in Excel

I have the below macro which inserts an array of data on each alternative row.
This works well, however, my data changes all the time so it is not the best method.
Sub inserttexteveryonerow()
Dim Last As Integer
Dim emptyRow As Integer
Last = Range("A" & Rows.Count).End(xlUp).Row
For emptyRow = Last To 2 Step -1
If Not Cells(emptyRow, 1).Value = "" Then
Rows(emptyRow).Resize(1).insert
Range(Cells(emptyRow, "A"), Cells(emptyRow, "F")).Value = Array("COLA", "COLB", "COLC", "COLD", "COLD", "COLF")
End If
Next emptyRow
End Sub
I want to have my data on Sheet1, but my alternate insert row on Sheet2 which has the specific data.
How can I edit this row:
Range(Cells(emptyRow, "A"), Cells(emptyRow, "F")).Value = Array("COLA", "COLB", "COLC", "COLD", "COLD", "COLF")
From inserting specific data to inserting the range on SHEET2 rows A1 to AF?
Assuming your request is to insert the range on Sheet2 from cell A1 to cell F1, the following should work:
Sub inserttexteveryonerow()
Dim Last As Integer
Dim emptyRow As Integer
Last = Range("A" & Rows.Count).End(xlUp).Row
For emptyRow = Last To 2 Step -1
If Not Cells(emptyRow, 1).Value = "" Then
Rows(emptyRow).Resize(1).insert
Range(Cells(emptyRow, "A"), Cells(emptyRow, "F")).Value = Worksheets("Sheet2").Range("A1:F1").Value
End If
Next emptyRow
End Sub
However, it would be a good idea to rewrite your code to use a With block, which will make it easier to correctly identify which sheets you are referring to:
Sub inserttexteveryonerow()
Dim Last As Integer
Dim emptyRow As Integer
With Worksheets("Sheet1")
Last = .Range("A" & .Rows.Count).End(xlUp).Row
For emptyRow = Last To 2 Step -1
If Not .Cells(emptyRow, 1).Value = "" Then
.Rows(emptyRow).Resize(1).insert
.Range(.Cells(emptyRow, "A"), .Cells(emptyRow, "F")).Value = Worksheets("Sheet2").Range("A1:F1").Value
End If
Next emptyRow
End With
End Sub
(Correctly qualifying which sheet you are referring to when using Range, Cells, etc, will prevent a lot of errors later.)

Fill in Column with values from another column if statement(s)

I currently have a VBScript that takes in an Excel document and re-formats it into another Excel document that's more organized.
This code must also look at the values of the CATALOG column ("B1") and place it in the Drawings column ("M1") ONLY if the beginning of the value starts with "EDASM", "EDBSM" etc., yet the "ED" prefix must be eliminated when it's moved.
For example, Catalog number EDF12-01114 would result in nothing being placed in the drawings column, but with EDSM10265, we would need SM10265 to be placed in the drawings column (drop the "ED").
All I've got so far is this, which isn't even complete:
Set objRange = objWorkSheet.Range("M1").EntireColumn
IF
objWorkSheet.Range("B1").Row = "EDF*" THEN 'Maybe correct-ish? Not sure about syntax
objRange = Null
Else
objRange = ("B1") 'Totally an awful guess, but I have no clue what to put here
End If
I've seen similar code that has loops and whatnot, but none of them seem to be doing what I need to be done. Thank you!
EDIT: Current code based off of BruceWayne's. Still doesn't return anything in Excel datasheet's Drawing column, but it looks like it's closer...
Sub move_Text()
Dim lastRow, nextRow, cel , rng
lastRow = Cells(Rows.Count, 2).End(xlUp).Row ' Since your Col. B is the data, let's find that column's last row
Set rng = Range(Cells(1, 2), Cells(lastRow, 2))
nextRow = 1
For Each cel In rng
If Left(cel.Value, 3) <> "EDF" Then
Cells(nextRow, 13).Value = Mid(cel.Value, 3, Len(cel.Value) - 2)
nextRow = nextRow + 1
End If
Next
End Sub
Another edit!
Catalog column is now "C", not "B". Also, I have two header rows, so the first catalog number is located in "C3".
Thanks again! We're getting closer.
Here's the Google Drive files: https://drive.google.com/folderview?id=0B2MeeQ3BKptFYnZfQWpwbTJxMm8&usp=sharing
IMPORTANT TO REMEMBER
In the Google Drive files: TestScript.vbs is the file where all the code is. When the script is run, select ExcelImport. That should return FinalDocument
I guess this is what you are looking for:
Sub move_Text()
Dim lastRow, nextRow, cel, rng
'get last row with data in Column B
lastRow = Cells(Rows.Count, "B").End(xlUp).Row
'set your range starting from Cell B2
Set rng = Range("B2:B" & lastRow)
'loop through all the cells in the range to check for "EDF" and "ED"
For Each cel In rng
'below condition is to check if the string starts with "EDF"
If cel.Value Like "EDF*" Then
'do nothing
'below condition is to check if the string starts with "ED"
ElseIf cel.Value Like "ED*" Then
'drop first two characters of cell's value and write in Column M
cel.Offset(0, 11).Value = Right(cel.Value, Len(cel.Value) - 2)
'else condition will be executed when none of the above two conditions are satisfied
'else condition is based on the link mentioned in your question that will handle words like "ELECTRICAL BOX"
Else
'write cell's value in Column Q
cel.Offset(0, 11).Value = cel.Value
End If
Next
End Sub
EDIT : For VBScirpt
________________________________________________________________________________
Sub Demo()
Dim lastRow, nextRow, cel, rng
Const xlShiftToRight = -4161
Const xlUp = -4162
Const xlValues = -4163
Const xlWhole = 1
Const xlPrevious = 2
With objWorksheet
'get last row with data in Column B
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
'set your range starting from Cell B2
Set rng = .Range("C2:C" & lastRow)
End With
'loop through all the cells in the range to check for "EDF" and "ED"
For Each cel In rng
'below condition is to check if the string starts with "EDF"
If InStr(1, cel.Value, "EDF", 1) = 1 Then
'do nothing
'below condition is to check if the string starts with "ED"
ElseIf InStr(1, cel.Value, "ED", 1) = 1 Then
'drop first two characters of cell's value and write in Column M
cel.Offset(0, 10).Value = Right(cel.Value, Len(cel.Value) - 2)
'else condition will be executed when none of the above two conditions are satisfied
'else condition is based on the link mentioned in your question that will handle words like "ELECTRICAL BOX"
Else
'write cell's value in Column M
cel.Offset(0, 10).Value = cel.Value
End If
Next
End Sub
How's this work for you?
Sub move_Text()
Dim lastRow&, nextRow&
Dim cel As Range, rng As Range
lastRow = Cells(Rows.Count, 2).End(xlUp).Row ' Since your Col. B is the data, let's find that column's last row
Set rng = Range(Cells(1, 2), Cells(lastRow, 2))
nextRow = 1
For Each cel In rng
If Left(cel.Value, 2) = "ED" Then
Cells(nextRow, 13).Value = Mid(cel.Value, 3, Len(cel.Value) - 2)
nextRow = nextRow + 1
End If
Next cel
End Sub
It will set the range to be your Column B, from row 1 to the last row. Then, loop through each cell in there, checking the left two letters. If "ED", then move the data, but take off the "ED".
Edit: Just realized you're using VBScript. Remove the as Range and & from the declarations, so it's just Dim lastRow, nextRow, cel, rng.
If your criteria is met, this will copy values (minus the ED prefix) from Column B to Column M.
Sub move_Text()
Dim lastRow , i
lastRow = Cells(Rows.Count, 3).End(xlUp).Row
For i = 3 To lastRow
If Left(Cells(i, 3), 2) = "ED" And Not (Left(Cells(i, 3), 3) = "EDF") Then
Cells(i, 13).Value = Right(Cells(i, 3, Len(Cells(i, 3)) - 2)
End If
Next
End Sub
Why not use some of excel's formulas to speed the whole thing up:
Sub My_Amazing_Solution ()
Range("M3").FormulaR1C1 = "=IF(TRIM(LEFT(RC[-10],2))=""ED"",RIGHT(TRIM(RC[-10]),LEN(RC[-10])-2),"""")"
Range("M3").AutoFill Destination:=Range("M3:M" & Range("C1048576").End(xlUp).Row), Type:=xlFillDefault
Application.Wait Now + TimeValue("00:00:03")
Range("M3:M" & Range("C1048576").End(xlUp).Row).Copy
Range("M3").PasteSpecial xlPasteValues
End sub
This should do it for you!

Resources