a bit of an odd one. I have a file with large amount of info that goes up to column "CH". Information in the workbook is spread through multiple tabs and when I consolidate data it copies everything except for the last column. Wonder if you could help me with that
Sub consolidation()
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("Consolidation").Delete
Application.DisplayAlerts = True
With ActiveWorkbook
Set Destination = .Sheets.Add(After:=.Sheets(.Sheets.Count))
Destination.Name = "Consolidation"
End With
Dim i As Integer
Dim stOne As Worksheet
Dim stOneLastRow As Long
Dim stTwo As Worksheet
Dim stTwoLastRow As Long
Dim consolid As Worksheet
Dim consolidLastRow As Long
Set stOne = ThisWorkbook.Sheets("Sheet1")
Set stTwo = ThisWorkbook.Sheets("Sheet2")
Set consolid = ThisWorkbook.Sheets("Consolidation")
stOneLastRow = stOne.Range("C" & Rows.Count).End(xlUp).Row
stTwoLastRow = stTwo.Range("C" & Rows.Count).End(xlUp).Row
consolidLastRow = consolid.Range("C" & Rows.Count).End(xlUp).Row
For i = 6 To stOneLastRow
stOne.Select
If stOne.Range("C6").Value = "OM ID" Then
Cells(i, 3).Resize(1, 100).Copy
consolid.Select
NextRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
Cells(NextRow, 2).Select
ActiveSheet.Paste
stOne.Select
End If
Next i
For i = 7 To stTwoLastRow
stTwo.Select
If stTwo.Range("C6").Value = "OM ID" Then
Cells(i, 3).Resize(1, 100).Copy
consolid.Select
NextRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
Cells(NextRow, 2).Select
ActiveSheet.Paste
stTwo.Select
End If
Next i
End Sub
Initial code is taken from here: https://learn.microsoft.com/en-us/office/vba/api/excel.range.copy
Tried to copy rows based on the value in CH cell, but still copies everything except for that column...
Very weird :-(
Omg... I feel so stupid. The data starts from 3rd column, but I copied everything starting from the 2nd colum... macro works correctly, just needed to change the column...
Related
I am working on a Macro that will copy every other value in a column of data and paste continuously to a new column in a new sheet. In my code below, the For i = 4 To LastRowC Step 2 loop is working, as it works out that the first empty row to paste is in the right spot.
However, for the For i = 4 To LastRowC Step 2 loop, the macro is finding a row too far down, as there is another filled row throwing it off, and I need to designate it to start pasting higher up at a specific cell. But it still needs to look for empty rows for pasting after for the duration of the for loop. Is this possible?
Option Explicit
Sub copyRange()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim wkbDest As Workbook
Dim wkbSource As Workbook
Set wkbDest = ThisWorkbook
Dim strExtension As String
Dim LastRowC As Long
Const strPath As String = "C:\Users\NGiuliano\Desktop\UPLOADS2\"
ChDir strPath
strExtension = Dir(strPath & "*.xls*")
Do While strExtension <> ""
Set wkbSource = Workbooks.Open(strPath & strExtension)
With wkbSource.Sheets("Sheet1")
LastRowC = wkbSource.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For i = 4 To LastRowC Step 2
wkbSource.Worksheets("Sheet1").Range("A" & i).Copy
wkbDest.Worksheets("WIP").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Next i
For j = 4 To LastRowC Step 2
wkbSource.Worksheets("Sheet1").Range("B" & j).Copy
wkbDest.Worksheets("WIP").Cells(Rows.Count, 16).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Next j
Application.CutCopyMode = False
End With
wkbSource.Close savechanges:=False
strExtension = Dir
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Will build on the code I provided in the last question:
Dim nextrow as Long 'Option 1; this dimension isn't appropriate for Option 2
nextrow = 2 'starting row for pasting, used for Option 1
For i = 4 to LastRowC Step 2
'Use Cells(i,"B") or Range("B" & i)
'Option 1, use a counter (declare "nextrow" as Long and define before the loop, e.g., 2)
wkbDest.Worksheets("WIP").Cells(nextrow,16).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
nextrow = nextrow + 1
'Option 2, find next cell each time using "end(xldown)"
set nextcell = wkbDest.Worksheets("WIP").Cells(2,16).End(xlDown).Offset(1)
nextcell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Next i
You can use either option, where nextrow is the row number and nextcell is the actual next cell that would be used.
In your code you're attempting to use a standard lastrow syntax (.End(xlUp)), which is great if needed... are you familiar with how that script actually works?
With Workbooks("Name").Sheets("Name")
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row 'Option 1
set nextcell = .Cells(.Rows.Count, 1).End(xlUp) 'Option 2
End With
In order it goes:
Find the workbook
Find the worksheet
Find the cell
Column found
Count of ALL rows in column found (i.e., 1,048,576)
From the last counted row go xlUp to the next cell with data
Now, you can either set that as a range, or you can .row/.column to find the parameter you want. In your example you did neither, and actually have inappropriate syntax in your .pastespecial line.
Spend some time to read up on the functionality of each line in your code and that might help move you forward!
I have written this code, and it works when doing it from one sheet to another. (Same workbook). But when i loop through the rows from workbook to workbook i get "Run time error 9" Subscript out of range.
I've checked several times if the filenames are as stated in the code, and it doesn't seem to be the problem. Also if I in the first piece write y.sheets("Tavledisplay") instead of worksheets("Tavledisplay") the debugger tells me there's a problem there. Doing it the latter way, it sends 1 loop of data, and stops at y.sheets("Tavledisplay").Activate.
My code:
Dim x As Workbook
Dim y As Workbook
Set x = Workbooks.Open("C:\Users\u054939\Desktop\Diverse filer\Safecard\Safecardmaster.xlsm")
Set y = Workbooks.Open("C:\Users\u054939\Desktop\Diverse filer\Safecard\Tavleark1.xlsm")
a = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
If Worksheets("Tavledisplay").Cells(i, 14).Value = "Ja" Then
Worksheets("Tavledisplay").Rows(i).Select
Selection.Copy
x.Sheets("Løsninger").Activate
b = Worksheets("Løsninger").Cells(Rows.Count, 1).End(xlUp).Row
x.Sheets("Løsninger").Cells(b + 1, 1).Select
ActiveSheet.Paste
y.Sheets("Tavledisplay").Activate
Selection.ClearContents
End If
Next i
Application.CutCopyMode = False
x.Sheets("Løsninger").Select
I expect the code to loop through all the given rows, where there is a "Ja" in column 14, and pasting them into my other workbook sheet "Løsninger" and deleting them from the other workbook.
You don't need to loop through each loop, a simple filter will do the trick:
Option Explicit
Sub Test()
Dim x As Workbook
Dim y As Workbook
Dim CopyRange As Range
Dim LastRow As Long
Set x = Workbooks.Open("C:\Users\u054939\Desktop\Diverse filer\Safecard\Safecardmaster.xlsm")
Set y = Workbooks.Open("C:\Users\u054939\Desktop\Diverse filer\Safecard\Tavleark1.xlsm")
'Look for the range to copy and set it
With y.Worksheets("Tabledisplay")
.UsedRange.AutoFilter Field:=14, Criteria1:="Ja"
LastRow = .Cells(.Rows.Count, 14).End(xlUp).Row
Set CopyRange = .Range("A2", .Cells(LastRow, .UsedRange.Columns.Count)).SpecialCells(xlCellTypeVisible)
.AutoFilterMode = False
End With
'Paste it to the other sheet
With x.Worksheets("Løsninger")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
CopyRange.Copy .Cells(LastRow, 1)
End With
'Delete the range from the original sheet
CopyRange.Delete
End Sub
I have two worksheets in one Excel workbook, and I only want to take the lines that have data in the cell (from worksheet1 into worksheet2) if Column A has data in it. My formula in worksheet 2 is =IF('Raw Data'!A2<>"", 'Raw Data'!A2,), but I actually don't want it to bring in the row at all if there is no data as shown in Rows 3 and 5. Right now it is bringing the whole row in:
In
you see that it is still bringing the row into worksheet 2 if there is no data. Any ideas how to only bring in the rows with the data?
Sub DataInCell()
Dim rw As Long
rw = 2
' Select initial sheet to copy from
Sheets("Raw Data").Select
' Find the last row of data - xlUp will check from the bottom of the spreadsheet up.
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' For loop through each row
For x = 2 To FinalRow
If Cells(x, 1).Value <> 0 Then
Range("A" & x & ":C" & x).Copy
Sheets("Sheet1").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1 'Continue incrementing through the rows.
Cells(NextRow, 1).Select ' Find the next row.
ActiveSheet.Cells(NextRow, "A").PasteSpecial xlPasteAll ' Paste information.
Sheets("Raw Data").Select 'Reselect sheet to copy from. Probably uneccessary.
End If
Next x
End Sub
After you update the sheet names on the 3rd and 4th line, you will see that the code carries over the entire row. You can modify using Range(Cells, Cells) if you want partial ranges.
Option Explicit
Sub Non_Blanks()
Dim ms As Worksheet: Set ms = ThisWorkbook.Sheets("Sheet1") '<-- Master Sheet
Dim ns As Worksheet: Set ns = ThisWorkbook.Sheets("Sheet2") '<-- New Sheet
Dim i As Long, MoveMe As Range, LR As Long
For i = 2 To ms.Range("B" & ms.Rows.Count).End(xlUp).Row
If ms.Range("A" & i) = "*" Then
If Not MoveMe Is Nothing Then
Set MoveMe = Union(MoveMe, ms.Range("A" & i))
Else
Set MoveMe = ms.Range("A" & i)
End If
End If
Next i
If Not MoveMe Is Nothing Then
LR = ns.Range("A" & ns.Rows.Count).End(xlUp).Offset(1).Row
MoveMe.EntireRow.Copy
ns.Range("A" & LR).PasteSpecial xlPasteValuesAndNumberFormats
End If
End Sub
Intended Result
If a row in a table contains any of the listed strings in column L on Sheet1, Then copy the entire row from Sheet1 and paste the row into a duplicate table on Sheet2 (which would be blank at the beginning).
(UNINTERESTED, UNRELATED, UNDECIDED, etc...)
Then delete the entire row that was transferred from sheet 1.
After macro runs, the new transfers should not reset table on Sheet2, rather add rows on the pre-existing lines. This document would be utilized over months.
Variables
Sheet1 is named Pipeline_Input
Sheet2 is named Closed_Sheet
Sheet1 table is named tblData
Sheet2 table is named tblClosed
Images
Image 1 is the code with error
Image 2 is Sheet 1 with some picture explanation
Image 3 is Sheet 2 with some picture explanation
Current Result
Run-time error '1004':
Application-defined or object-defined error
Sub closedsheet()
Application.ScreenUpdating = False
Dim Pipeline_input As Worksheet 'where is the data copied from
Dim Closed_Sheet As Worksheet 'where is the data pasted to
Dim strPhase() As String
Dim i As Integer
Dim intPhaseMax As Integer
Dim lngLstRow As Long
Dim rngCell As Range
Dim finalrow As Integer
Dim lr As Long 'row counter
Dim Looper As Integer
intPhaseMax = 6
ReDim strPhase(1 To intPhaseMax)
strPhase(1) = "LOST"
strPhase(2) = "BAD"
strPhase(3) = "UNINTERESTED"
strPhase(4) = "UNRELATED"
strPhase(5) = "UNDECIDED"
strPhase(6) = "BUDGET"
'set variables
Set Pipeline_input = Sheet1
Set Closed_Sheet = Sheet2
lr = Range("A" & Rows.Count).End(xlUp).Row
For Looper = LBound(strPhase) To UBound(strPhase)
For i = lr To 6 Step -1
Next
If Not Sheet1.Range("L9:L300" & lngLstRow).Find(strPhase(Looper), lookat:=xlWhole) Is Nothing Then
Range(Cells(i, 1), Cells(i, 20)).Copy
Sheet2.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
Range(Cells(i, 1), Cells(i, 20)).Delete
End If
Next
Sheet2.Select
Sheet2.columns.AutoFit
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Okay, there were a plethora of issues with the code you posted, but I decided to help you out here - Notice a few things - There's no copying and pasting here - we're just transferring data.
Secondly, use easy to understand variables. lr and lngLastRow can't be distinguished from one another, so classify them by which worksheet you're getting that value from.
We create an array in one fell swoop here - Just declare a variant and place our values in. ARRAYS (TYPICALLY) START AT ZERO, NOT ONE, so our loop starts at 0 :). Again, this is what's known as best practice...
I swapped out Looper for j. Again, keep. it. simple!
EDIT: I tested this code out on a simulated workbook and it worked fine - should run into no issues for you either.
EDIT2: Also, always use Option Explicit!
Option Explicit
Sub closedsheet()
Application.ScreenUpdating = False
Dim Pipeline_Input As Worksheet 'source sheet
Dim Closed_Sheet As Worksheet 'destination sheet
Dim i As Long, j As Long, CSlastrow As Long, PIlastrow As Long
Dim strPhase As Variant
'Here we create our array
strPhase = Array("LOST", "BAD", "UNINTERESTED", "UNRELATED", "UNDECIDED", "BUDGET")
'Assign worksheets
Set Pipeline_Input = ActiveWorkbook.Worksheets("Pipeline_Input")
Set Closed_Sheet = ActiveWorkbook.Worksheets("Closed_Sheet")
PIlastrow = Pipeline_Input.Range("A" & Rows.Count).End(xlUp).Row
For j = 0 To UBound(strPhase)
For i = PIlastrow To 6 Step -1
If Pipeline_Input.Range("L" & i).Value = strPhase(j) Then
'Refresh lastrow value
CSlastrow = Closed_Sheet.Range("A" & Rows.Count).End(xlUp).Row
'Transfer data
Closed_Sheet.Range("A" & CSlastrow + 1 & ":S" & CSlastrow + 1).Value = _
Pipeline_Input.Range("A" & i & ":S" & i).Value
'Delete the line
Pipeline_Input.Range("A" & i & ":S" & i).EntireRow.Delete
End If
Next i
Next j
Closed_Sheet.Select
Closed_Sheet.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
I pasted the entire macro below but this is the important part.
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Range("D2:D10000").Value = Range("D2").Offset(-1, 1).Value
Range("F2:F10000").Value = Range("F2").Offset(-1, 1).Value
Range("H2:H10000").Value = Range("H2").Offset(-1, 1).Value
It works as is except it is creating unnecessary data because I don't know how to use variable names in a range object. My ranges are currently hard coded such as ("A1:A1000"), when I would like it to be something like ("A1:A & LastRow).
Also I have to explicitly call out column names to copy because the range won't accept a variable name like ("currentColumn & 1:currentColumn & LastRow).
Is there a way to use a varible name as part of a range object so we can use them in loops?
Sub prepareWorkbook()
Dim wbk As Workbook
Set wbk = ThisWorkbook
Dim wks As Worksheet
Set wks = wbk.ActiveSheet
Dim colx As Long
Dim ColumnCount As Long
Dim MySheetName As String
MySheetName = "Import"
LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
ActiveSheet.Name = MySheetName
'identify the Id column and move it to 1st column
Dim answer As Variant
Dim IdColumn As Range
answer = Application.InputBox("Enter Letter of Id column")
If Columns(answer).Column = 1 Then
Else
'cut Id column from current location and insert it at column index 1
Columns(answer).Select
Selection.Cut
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
End If
'trim the PartNumber column of any trailing spaces
Dim c As Range
For Each c In Range("A1:A10000")
c.Value = Application.Trim(Replace(c.Value, Chr(160), Chr(32)))
Next
' insert column every other column
' Loop through number of columns.
ColumnCount = Application.WorksheetFunction.CountA(Rows(1)) * 2
'step 2 means skip every other
For colx = 2 To ColumnCount Step 2
Columns(colx).Insert Shift:=xlToRight
Next
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Range("D2:D10000").Value = Range("D2").Offset(-1, 1).Value
Range("F2:F10000").Value = Range("F2").Offset(-1, 1).Value
Range("H2:H10000").Value = Range("H2").Offset(-1, 1).Value
wks.Cells.EntireColumn.AutoFit
MsgBox ("Done")
End Sub
Assuming the you are running code in the Worksheet added here:
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
ActiveSheet.Name = MySheetName
Also not sure what is the purpose of this code, nevertheless using it for the sample
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Try this:
Dim lLastRow As Long
lLastRow = wbk.Worksheets(MySheetName).UsedRange.SpecialCells(xlLastCell).Row
Rem This updates only columns B, D, F & H - adjust as needed
For colx = 2 To 8 Step 2
With wbk.Worksheets(MySheetName)
Rem Creates Range as Range(Cells(rIni,cIini), Cells(rEnd,cEnd))
rem Corresponding code for "Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value" (see comment above)
Range(.Cells(2, colx), .Cells(lLastRow, colx)) = .Cells(2, colx).Offset(-1, 1).Value
End With: Next
Something like:
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("B2:B" & LastRow).Value = Range("B2").Offset(-1, 1).Value
Range("D2:D" & LastRow).Value = Range("D2").Offset(-1, 1).Value
Range("F2:F" & LastRow).Value = Range("F2").Offset(-1, 1).Value
Range("H2:H" & LastRow).Value = Range("H2").Offset(-1, 1).Value
Although this answer won't be applied to your situation, I feel like this could help answer some questions you have in there.
When specifying a range, you can separate the column (letter) and row (number) and use your own variables.
In a for loop, this could look like
for i = 1 to 100
Range("A" & i).Value = Range("A"&i).Offset(, 1).Value
next
You can also determine the number of the row of the selected cell using:
dim RowNb as long
RowNb = (ActiveCell.Row)
This also applies to columns, and can be used in a loop like I mentionned at the start.
The one thing that was conspicuous by its absence in your description was any mention of the nature of the data in the worksheet. You mentioned A1 briefly but your range value assignments started at row 2 so it may be inferred that row 1 contains column header labels.
Sub prepareWorkbook()
Dim wbk As Workbook, wks As Worksheet
Dim colx As Long
Dim lc As Long, lr As Long
Dim MySheetName As String
Set wbk = ThisWorkbook 'no idea what this does
Set wks = wbk.ActiveSheet 'no idea what this does
MySheetName = "Import"
'no idea what this does or what sht is
'LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
With Sheets(2)
.Name = MySheetName
If CBool(Application.CountIf(.Rows(1), "PartNumber")) Then
colx = Application.Match("PartNumber", .Rows(1), 0)
Else
colx = .Range(Application.InputBox("Enter Letter of Id column") & 1).Column
End If
If .Columns(colx).Column > 1 Then
'cut Id column from current location and insert it at column index 1
.Columns(colx).Cut
.Columns(1).Insert Shift:=xlToRight
End If
'quickest way to trim trailing spaces is with Text-to-Columns, Fixed Width
With .Columns(1)
.TextToColumns Destination:=.Cells(1), DataType:=xlFixedWidth, FieldInfo:=Array(0, 1)
End With
' insert column every other column (working backwards toward A1)
For lc = .Cells(1, Columns.Count).End(xlToLeft).Column To 2 Step -1
.Columns(lc).Insert Shift:=xlToRight
Next lc
For lc = (.Cells(1, Columns.Count).End(xlToLeft).Column - 1) To 2 Step -2
'let's put the row-by-row value in instead of a single value into all cells
lr = .Cells(Rows.Count, lc + 1).End(xlUp).Row
With .Cells(2, lc).Resize(lr - 1, 1)
.Cells = .Offset(-1, 1).Value
.EntireColumn.AutoFit
End With
Next lc
End With
Set wbk = Nothing
Set wks = Nothing
End Sub
Explanations as comments in code.