I want to say thank you for the help I've been getting lately. So I am testing the VBA and I noticed that when I copy and paste data to the worksheet, it would overwrite the hidden rows. Is there a way to copy and paste the data without overwriting the hidden rows?
Public Sub CNPInStock()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lr1 As Long, lr2 As Long
Set ws1 = ThisWorkbook.Sheets(Sheets.Count) 'Last Worksheet
Set ws2 = ThisWorkbook.Sheets(Sheets.Count - 1) 'Second to Last Worksheet
lr1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Offset(1).Row
lr2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
ws2.Range("A1:C" & lr2).Autofilter Field:=3, Criteria1:=">0", Operator:=xlFilterValues
ws2.Range("A2:C" & lr2).SpecialCells(xlCellTypeVisible).Copy
ws1.Range("A" & lr1).PasteSpecial xlPasteValues
End Sub
It is the same behavior as with normal copy and paste operation done without VBA.
While you can simultaneously copy data from the multiple rows by Selecting visible cells and then Copying, you cannot Paste into multiple regions with one single operation (if some rows are filtered out, this is basically what you are trying to do).
You need to loop with For ... Next through each row to paste the data.
Maybe the following solution will help you:
Sub CNPInStock()
'source-sheet
Dim sws As Worksheet
'target-sheet
Dim tws As Worksheet
Dim i As Long
Dim j As Long
Dim iEnd As Long
Set sws = Sheets("Source")
Set tws = Sheets("Target")
'only for faster calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'get end of source-sheet
iEnd = sws.Range("A" & sws.Rows.Count).End(xlUp).Row
'init row for target-sheet
j = 1
'loop the source-sheet
For i = 1 To iEnd
'your filter in column 3 with value > 0
If sws.Cells(i, 3).Value > 0 Then
'check if row in target-sheet is hidden
Do Until tws.Rows(j).Hidden = False
j = j + 1
Loop
'copy source to target
sws.Range(Cells(i, 1), Cells(i, 3)).Copy Destination:=tws.Cells(j, 1)
j = j + 1
End If
Next i
'back to automatic (slower) calculation
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
Related
I'm working in Excel 2016, and I have a macro where I'm trying to remove ALL duplicated rows from the main worksheet and move them to the Duplicates worksheet starting at A3 and what is happening is that in the Duplicates worksheet is that it is cutting only 1 of the rows and NOT both rows from the Main worksheet. Any help/direction as to what I'm doing wrong would be appreciated. Thanks.
Here is my macro code:
Sub CutDuplicates()
Dim Rng As Range, i As Long
Application.ScreenUpdating = False
Set Rng = Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
For i = Rng.Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountIf(Rng, Cells(i, "A")) > 1 Then
lr = Sheets("Duplicates").Cells(Rows.Count, "A").End(xlUp).Row + 1
Rows(i).EntireRow.Cut Destination:=Sheets("Duplicates").Range("A" & lr)
Rows(i).EntireRow.Delete
End If
Next i
Application.ScreenUpdating = True
End Sub
Note there's a subtle bug in your posted code: Rng starts in Row#3, but in your loop i is relative to Rng, not the whole sheet, so (eg) when i=1 that's Row#3 on the sheet, not Row#1.
Instead of cutting as you go, you can collect the rows to be cut and then move them:
Sub CutDuplicates()
Dim Rng As Range, i As Long, col As New Collection, ws As Worksheet
Dim c As Range
Application.ScreenUpdating = False
Set ws = ActiveSheet 'always qualify all ranges with a worksheet object...
Set Rng = ws.Range("A3:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
'collect all duplicate rows
For i = 1 To Rng.Rows.Count
If Application.WorksheetFunction.CountIf(Rng, Rng.Rows(i).Value) > 1 Then
col.Add i 'store row# in collection
End If
Next i
'now cut the duplicates to the other sheet
Set c = Sheets("Duplicates").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
For i = col.Count To 1 Step -1 'step backwards through the rows
Rng.Rows(col(i)).EntireRow.Cut Destination:=c
Set c = c.Offset(1, 0) 'next paste destination
Rng.Rows(col(i)).EntireRow.Delete
Next i
Application.ScreenUpdating = True
End Sub
I have a workbook that contains 300 sheets Jan1990, Feb1990,....Dec2016.
Each sheet contains data in column A1:AS11 and I want only AR column Data (11 rows in each column) from all 300 sheets in the sheet named as "Masters".
I found one code on the forum but I need to change the sheet name again and again to get the data in the below code. Also AR column contain formula so I need the Value only not the formula.
Sub Demo()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim path As String, fileName As String
Dim lastRowInput As Long, lastRowOutput As Long, rowCntr As Long, lastColumn As Long
Dim inputWS As Worksheet, outputWS As Worksheet
'set your sheets here
Set inputWS = ThisWorkbook.Sheets("SEP2014")
Set outputWS = ThisWorkbook.Sheets("Master")
rowCntr = 1
'get last rows from both sheets
lastRowInput = inputWS.Cells(Rows.Count, "A").End(xlUp).Row
lastRowOutput = outputWS.Cells(Rows.Count, "A").End(xlUp).Row
lastColumn = inputWS.Cells(1, Columns.Count).End(xlToLeft).Column
'copy data from columns AR, AS
inputWS.Range("AR1:AR11" & lastRowInput).Copy outputWS.Range("F" & lastRowOutput + 1)
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Edited your code .. As suggested by BigBen it contains a loop to copy AR Columns from all sheets other than Master. It is pasted one below the previous in the F column of the master sheet as per your code. You can also paste them side by side. Assuming 'Master' sheet is Sheet(1), loop starts with i = 2 i.e. Sheet(2)
Sub Demo()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim path As String, fileName As String
Dim lastRowInput As Long, lastRowOutput As Long, rowCntr As Long, lastColumn As Long
Dim inputWS As Worksheet, outputWS As Worksheet
'set your sheets here
'Set inputWS = ThisWorkbook.Sheets("SEP2014")
Set outputWS = ThisWorkbook.Sheets("Master")
rowCntr = 1
For i = 2 To ThisWorkbook.Sheets.Count
If ThisWorkbook.Sheets(i).Name <> "Master" Then
Set inputWS = ThisWorkbook.Sheets(i)
'get last rows from both sheets
lastRowInput = inputWS.Cells(Rows.Count, "A").End(xlUp).Row
'lastRowOutput = outputWS.Cells(Rows.Count, "A").End(xlUp).Row
lastRowOutput = outputWS.Cells(Rows.Count, "F").End(xlUp).Row
lastColumn = inputWS.Cells(1, Columns.Count).End(xlToLeft).Column
'copy data from columns AR, AS
'inputWS.Range("AR1:AR11" & lastRowInput).Copy outputWS.Range("F" & lastRowOutput + 1)
' to paste them one below the prevous.
inputWS.Range("AR1:AR" & lastRowInput).Copy outputWS.Range("F" & lastRowOutput + 1)
' to paste them side by side from F column.
'inputWS.Range("AR1:AR" & lastRowInput).Copy outputWS.Cells(1, 4 + i)
End If
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Just a small change required, pass the worksheet name into your sub, then in another sub loop on a list of sheet names:
Sub LoopOnSheets()
dim sheetNames() as string
dim x as integer
sheetNames = split("sheet name one,sheet name two,and so on",",") ' list your sheets here separated by a comma
for x = 0 to ubound(sheetNames) - 1
Demo Sheets(sheetNames(x)) ' this will pass the sheet to your Demo sub to work on
next x
End Sub
Sub Demo(inputWS As Worksheet)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim path As String, fileName As String
Dim lastRowInput As Long, lastRowOutput As Long, rowCntr As Long, lastColumn As Long
Dim outputWS As Worksheet
'set your sheets here
Set outputWS = ThisWorkbook.Sheets("Master")
rowCntr = 1
'get last rows from both sheets
lastRowInput = inputWS.Cells(Rows.Count, "A").End(xlUp).Row
lastRowOutput = outputWS.Cells(Rows.Count, "A").End(xlUp).Row
lastColumn = inputWS.Cells(1, Columns.Count).End(xlToLeft).Column
'copy data from columns AR, AS
inputWS.Range("AR1:AR11" & lastRowInput).Copy outputWS.Range("F" & lastRowOutput + 1)
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I have data in a table, where I compare two columns J and T. The values which J and T can take include A2B, APL, BGF, CMA, among others (see code).
If these values are equal, copy row i into the sheet which has the name of the cells just checked.
If these values are not equal, copy row i into the sheets which have the name of the cells just checked.
Example: Compare J2 and T2,
Suppose J2=T2=BGF then copy row 2 and paste into sheet("BGF")
Next, compare J3 and T3
Suppose J3=BGF and T3=CMA, copy row 3 and paste into sheet(BGF) and sheet(CMA)
Next, compare J4 and T4
Suppose J4=Nothing and T4=CMA, copy row 4 and paste into sheet CMA
the only other combination is where Ji has a value and Ti is empty.
Problem: When running this code, If J3=BGF and T3= nothing (its empty), then the line is not copied to any sheet.
Here's the code
Sub Sortdata()
'step 1 clear all data
Sheets("A2B").Cells.ClearContents
Sheets("APL").Cells.ClearContents
Sheets("BGF").Cells.ClearContents
Sheets("CMA").Cells.ClearContents
Sheets("K Line").Cells.ClearContents
Sheets("MacAndrews").Cells.ClearContents
Sheets("Maersk").Cells.ClearContents
Sheets("OOCL").Cells.ClearContents
Sheets("OPDR").Cells.ClearContents
Sheets("Samskip").Cells.ClearContents
Sheets("Unifeeder").Cells.ClearContents
Dim i As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim LastRow As Long
With Worksheets("All Data")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
If IsEmpty(.Range("J" & i)) Then
Set ws1 = Nothing
Else
Set ws1 = Worksheets(.Range("J" & i).Value)
End If
If IsEmpty(.Range("T" & i)) Then
Set ws2 = Nothing
Else
Set ws2 = Worksheets(.Range("T" & i).Value)
End If
If ws1 Is Nothing Then
If Not ws2 Is Nothing Then
CopyToWs ws2, .Rows(i)
End If
ElseIf ws2 Is Nothing Then
If Not ws1 Is Nothing Then
CopyToWs ws1, .Rows(i)
End If
Else
CopyToWs ws1, Rows(i)
If ws1.Name <> ws2.Name Then
CopyToWs ws2, .Rows(i)
End If
End If
Next
End With
End Sub
Sub CopyToWs(ws As Worksheet, rng As Range)
rng.Copy
ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial xlPasteValuesAndNumberFormats
End Sub
Please try this code. It takes a slightly different approach to what you tried but it gets the job done, I think.
Option Explicit
Sub Sortdata()
' Variatus #STO 20 Jan 2020
Const WsNames As String = "A2B,APL,BGF,CMA,K Line,MacAndrews," & _
"Maersk,OOCL,OPDR,Samskip,Unifeeder"
Dim WsS As Worksheet ' Source
Dim Ws As Worksheet
Dim Rng As Range
Dim Rt As Long ' target row
Dim LastRow As Long
Dim J As Long, T As Long
Dim Tmp As Variant, PrevTmp As Variant
Dim R As Long, C As Long
'step 1 clear all data
Tmp = Split(WsNames, ",")
For R = LBound(Tmp) To UBound(Tmp)
On Error Resume Next
Worksheets(Tmp(R)).Cells.ClearContents
Next R
Application.ScreenUpdating = False
Set WsS = Worksheets("All Data")
With WsS
J = .Columns("J").Column
T = .Columns("T").Column
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For R = 2 To LastRow
PrevTmp = ""
For C = J To T Step T - J
Tmp = .Cells(R, C).Value
If Len(Tmp) And Tmp <> PrevTmp Then
On Error Resume Next
Set Ws = Worksheets(Tmp)
If Err = 0 Then
Set Rng = .Range(.Cells(R, 1), .Cells(R, .Columns.Count).End(xlToLeft))
With Ws
Rt = Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, 2)
Rng.Copy Destination:=Ws.Cells(Rt, 1)
End With
End If
End If
PrevTmp = Tmp
Next C
If R Mod 25 = 0 Then Application.StatusBar = "Currently processing row " & R
Next R
End With
With Application
.ScreenUpdating = True
.StatusBar = "Done"
End With
End Sub
I think you will be able to find your way through it and make any required modifications. Let me know if you require any assistance.
I have a code that should restore range formatting after applying few step.
Sub MyCode()
Sheets("My sheet").ListObjects("My Table").DataBodyRange.Copy
...
refreshing connection and calling function that applies stored formulas to table columns
...
Sheets("My sheet").[A10].PasteSpecial Paste:=xlPasteFormats
End sub
I got error PasteSpecial method on range failed
If I paste immediately, it works.
Is it possible to save range formatting as variable?
Here is an example on how to use variables to store the copy method and use it later. You can set the range to a variable CopyRange and use CopyRange.Copy to store it and later you can use it as the range was stored in the CopyRange and not lost along the way due to other processes running down the line.
Option Explicit
Sub CopyDataToTemplate()
Dim ws As Worksheet
Dim srcWB As Workbook
Dim destWB As Workbook
Dim srcWS As Worksheet
Dim destWS As Worksheet
Dim CopyRange As Variant
Dim i As Long, j As Long
Dim srcLRow As Long, destLRow As Long
Set destWB = Excel.Workbooks("DOLine_example.xlsx")
Set srcWB = ActiveWorkbook
Set srcWS = srcWB.ActiveSheet
Set destWS = destWB.Sheets("DOLine")
srcLRow = srcWS.Cells(srcWS.Rows.Count, "A").End(xlUp).Row
destLRow = destWS.Cells(destWS.Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
'loop through column 1 to 19
For i = 1 To 19
For j = 1 To 13
'loop through columns
If destWS.Cells(3, i).value = srcWS.Cells(1, j).value Then
' Copy column B to Column D as written in your code above
Set CopyRange = srcWS.Range(Cells(2, j), Cells(srcLRow, j))
CopyRange.Copy
' paste columns from one wb to Columns to another wb
destWS.Cells(destLRow, i).PasteSpecial Paste:=xlPasteAll, Transpose:=False
Application.CutCopyMode = False
End If
Next j
Next i
Application.ScreenUpdating = True
MsgBox "Process completed!", vbInformation
End Sub
I am currently using the following code to copy paste data from File- "Source" to File-"Destination". It is selecting the rows till data ends in Column-1.
However, currently all the columns from A to AE are selected, but instead I want selective columns like A,F,K,AA to be selected.
I understand that the code in "wb.ActiveSheet.Range("A2:AE" & N).Copy" needs to be changed but not sure of the syntax.
Can anyone help me with this? Appreciate the help in advance.
Dim wb As Workbook
Set wb = ActiveWorkbook
Dim N As Long
Dim LastRow As Long
N = Cells(2, 1).End(xlDown).Row
wb.ActiveSheet.Range("A2:AE" & N).Copy
Set y = Workbooks.Open("C:\Desktop\Destination.xlsx")
y.Activate
y.Sheets("Data").Select
y.Sheets("Data").Activate
For Each Cell In y.Sheets("Data").Columns(1).Cells
If Len(Cell) = 0 Then Cell.Select: Exit For
Next Cell
Selection.PasteSpecial Paste:=xlPasteValues
Application.DisplayAlerts = False
ActiveWorkbook.Close True
Application.DisplayAlerts = True
Application.CutCopyMode = False
You can use the Application.Union to combine ranges from different columns (from row 2 until N).
Also, instead of looping through your y.Sheets("Data").Columns(1).Cells to find the empty Cell, you can just use LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1.
I added 2 With wb.Sheets("Sheet1") to fully qualify all variables and Range nested underneath.
Code
Option Explicit
Sub CopyColumns()
Dim wb As Workbook
Dim Y As Workbook
Dim N As Long
Dim LastRow As Long
Dim CopyRng As range
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
' you need to specify the sheet, otherwise it will take the Active Sheet
With wb.Sheets("Sheet1") ' <-- modify to your sheet's name
N = .Cells(.Rows.Count, "A").End(xlUp).Row ' <-- get last row from Column "A", skips blank cells in te middle
' set the range to Columns A, F, K, AA
Set CopyRng = Application.Union(.Range("A2:A" & N), .Range("F2:F" & N), .Range("K2:K" & N), .Range("AA2:AA" & N))
End With
Set Y = Workbooks.Open("C:\Desktop\Destination.xlsx")
With Y.Sheets("Data")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 '<-- get first empty row at Column A to paste at
CopyRng.Copy
.Range("A" & LastRow).PasteSpecial xlPasteValues
End With
Y.Close True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub