The macro is suppose to copy a fixed table 1 ("E19:Q34") and paste it to a range which is 15 column offset of cell E19 i.e. "T19" and would be called 'Table 2'. the next time the macro runs it should be able to detect the table and further move ahead 15 columns to "AI19" and so on..
Sub Macro()
Application.ScreenUpdating = False
Dim Rng, rng1, rng2 As Range, ws As Worksheet,
Set ws = ActiveWorkbook.ActiveSheet
Set Rng = ActiveSheet.Range("E19")
Set rng1 = Rng.Offset(0, 15)
Set rng2 = ActiveSheet.Range("E19:Q34") 'fixed base range
'Copy the range with text and paste it after finding the right location
rng2.copy
rng1.Select
For Each rng1 In rng1.Cells
If rng1.Value = "" Then
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ws.Paste
Application.CutCopyMode = False
Exit For
Else
Range(rng1).Address = ActiveCell.Offset(0, 15) 'attempting to change the reference of rng1
' MsgBox rng1
End If
Next rng1
End sub
Try this:
Sub Macro()
Const COL_OFFSET As Long = 15
Dim rng, ws As Worksheet, cols As Long
Set ws = ActiveSheet
Set rng = ws.Range("E19:Q34")
Application.ScreenUpdating = False
rng.Copy
cols = COL_OFFSET
'find the next empty slot
Do While Application.CountA(rng.Offset(0, cols)) > 0
cols = cols + COL_OFFSET
Loop
With rng.Offset(0, cols)
.PasteSpecial Paste:=xlValues
.PasteSpecial Paste:=xlPasteColumnWidths
.PasteSpecial Paste:=xlPasteFormats
End With
End Sub
Related
I am creating a inventory control workbook and I am looking to have a column with the words "Order Placed" once I have clicked on the button to place order. I want to make sure that it is based on the right criteria. Currently in I am using a formula to place that text but once I clear the order form that goes away because its using an index match function within an if statement.
This is my current Order Placed Sub
Sub orderPlaced()
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim startCell As range, lastRow As Long, lastCol As Long, ws As Worksheet
Set ws = Sheets("Re-Order List")
'This part Copies the requested information
Sheets("Re-Order List").Select
range("A1").Select
Application.CutCopyMode = False
Selection.Copy
'This part Pastes the requested information in the history
Sheets("Order History").Select
Selection.End(xlDown).Select
range("A65536").Select
Selection.End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'This part Copies the requested information
Sheets("Re-Order List").Select
Set startCell = range("A3")
lastRow = ws.Cells(ws.Rows.Count, startCell.Column).End(xlUp).Row
lastCol = ws.Cells(startCell.Row, ws.Columns.Count).End(xlToLeft).Column
ws.range(startCell, ws.Cells(lastRow, lastCol)).Select
Application.CutCopyMode = False
Selection.Copy
'This part Pastes the requested information in the history
Sheets("Order History").Select
Selection.End(xlDown).Select
range("A65536").Select
Selection.End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'This part adds orderplaced below order form
Sheets("Order History").Select
range("A65536").Select
Selection.End(xlUp).Offset(2, 0).Select
With Selection
.Value = "Order Placed :"
.HorizontalAlignment = xlRight
End With
'This part adds the date
Sheets("Order History").Select
range("B65536").Select
Selection.End(xlUp).Offset(2, 0).Select
With Selection
.Value = Date
.NumberFormat = "dd/mmm/yyyy"
.HorizontalAlignment = xlLeft
End With
'this will set the comment in inventory to ordered
'*************************
'NEEDED CODE WILL GO HERE
'*************************
Sheets("Inventory").Select
range("K6:K400").ClearContents
'This part Clears the order form
Sheets("Re-Order List").Select
range("A4:D5000").ClearContents
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
This is my Add to Order Sub
Sub add2Order()
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim C As range, rng As range, D As range, Rng1 As range, mnrng As range, acrng As range
Sheets("Inventory").Select
Set rng = range("K6:K400")
For Each C In rng
If InStr(1, C, "X") > 0 Then
'first select material number and name
Set mnrng = range(C.Offset(0, -9), C.Offset(0, -8))
Application.CutCopyMode = False
mnrng.Copy
'paste in reorder sheet
Sheets("Re-Order List").Select
Selection.End(xlDown).Select
range("A400").Select
Selection.End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = True
End If
Next
Sheets("Inventory").Select
Set Rng1 = range("K6:K400")
For Each D In Rng1
If InStr(1, D, "X") > 0 Then
'Second select amount and cost
Set acrng = range(D.Offset(0, -2), D.Offset(0, -1))
Application.CutCopyMode = False
acrng.Copy
'paste in reorder sheet
Sheets("Re-Order List").Select
Selection.End(xlDown).Select
range("C400").Select
Selection.End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = True
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Code that is close is as follows
Sub test()
'
Dim w1 As Worksheet, w2 As Worksheet
Dim C As range, a As range
Set w1 = Sheets("Inventory")
Set w2 = Sheets("Re-Order List")
With w1
For Each C In .range("$A$6:$A$400")
Set a = w2.Columns(1).Find(C.Value, LookAt:=xlWhole)
If Not a Is Nothing Then
If IsEmpty(.Cells(C.Row, 1)) And .Cells(C.Row, 1).Value = w2.Cells(a.Row, 1) Then
w1.Cells(C.Row, 12).Value = "Order Placed"
End If
End If
Next C
End With
End Sub
This is the last piece to this puzzle to get it how I want it to work, I know for sure I will only have less than 400 materials to manage and if that grows I can update then but any help would be fantastic.
This is the drive link for the actual sheet
This isn't an answer until you tell us exactly where do you want to place the information
I refactored your code so you don't use select and added some pseudo code that may give you a hint
Public Sub orderPlaced()
' Turn off stuff to speed up process
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False
'This part Copies the requested information
Dim reorderListSheet As Worksheet
Set reorderListSheet = ThisWorkbook.Worksheets("Re-Order List")
reorderListSheet.Range("A1").Copy
'This part Pastes the requested information in the history
Dim orderHistorySheet As Worksheet
Set orderHistorySheet = ThisWorkbook.Worksheets("Order History")
orderHistorySheet.Cells(orderHistorySheet.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' Find last row in reorder sheet
Dim reorderLastRow As Long
reorderLastRow = reorderListSheet.Cells(reorderListSheet.Rows.Count, "A").End(xlUp).Row
' Find last column in reorder sheet
Dim reorderLastColumn As Long
reorderLastColumn = reorderListSheet.Cells(3, reorderListSheet.Columns.Count).End(xlToLeft).Column
'This part Copies the requested information
Dim reorderStartCell As Range
Set reorderStartCell = reorderListSheet.Range("A3")
reorderListSheet.Range(reorderStartCell, reorderListSheet.Cells(reorderLastRow, reorderLastColumn)).Copy
'This part Pastes the requested information in the history
Dim orderHistoryLastRow As Long
orderHistoryLastRow = orderHistorySheet.Cells(orderHistorySheet.Rows.Count, "A").End(xlUp).Row
orderHistorySheet.Range("A" & orderHistoryLastRow).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'This part adds orderplaced below order form
With orderHistorySheet.Range("A" & orderHistoryLastRow).Offset(3, 0)
.Value = "Order Placed :"
.HorizontalAlignment = xlRight
End With
'This part adds the date
With orderHistorySheet.Range("B" & orderHistoryLastRow).Offset(3, 0)
.Value = Date
.NumberFormat = "dd/mmm/yyyy"
.HorizontalAlignment = xlLeft
End With
'this will set the comment in inventory to ordered
'*************************
' THIS NEXT IS PSEUDO CODE BECAUSE I COULDN'T UNDERSTAND YOUR REQUIREMENT
Dim targetCell As Range
Set targetCell = orderHistorySheet.Range("A1").Value = "=IFERROR(IF(INDEX(Table2[Material Number],MATCH(C6,Table2[Name],0)) = [#[Material Number]],""Order Placed"",""""),"""")"
' turn that into a value
targetCell.Value = targetCell.Value
'*************************
' Clear inventory sheet
Dim inventorySheet As Worksheet
Set inventorySheet = ThisWorkbook.Worksheets("Inventory")
inventorySheet.Range("K6:K400").ClearContents
'This part Clears the order form
reorderListSheet.Range("A4:D5000").ClearContents
' Turn on stuff again
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
I FIGURED IT OUT!!!!!!!!
'this will set the comment in inventory to ordered
'*************************
Dim r1 As range
Dim r2 As range
Dim cell As range
Set r1 = Sheets("Inventory").range("B6:B400")
Set r2 = Sheets("Re-Order List").range("A4:A400")
For Each cell In r1
If IsError(Application.Match(cell, r2, 0)) Then
cell.Offset(, 12) = ""
Else
cell.Offset(, 12) = "Order Placed"
' If found I need the value from Sheet2 that is in Col B of the matching row.
End If
Next cell
'*************************
I have this below macro code that performs a transpose a range of cells.
Sub Macro45()
'
' Macro45 Macro
' r3
'
' Keyboard Shortcut: Ctrl+e
'
Range("F2:G8").Select
Selection.Copy
Range("H2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End Sub
I am trying to see how could I repeat the same process for entire range of rows. My dataset has about 10000 rows and I want to perform the same tasks over the entire range.
It seems you taking particular steps of 7 rows. So maybe try:
Sub Test()
Dim lr As Long, x As Long
With ThisWorkbook.Worksheets("Sheet1") 'Change accordingly
'Find last used row
lr = .Cells(.Rows.Count, 6).End(xlUp).Row
'Step through data and transpose values
For x = 2 To lr Step 7
.Cells(x, 8).Resize(2, 7).Value = Application.Transpose(.Range(.Cells(x, 6), .Cells(x + 6, 7)).Value)
Next x
End With
End Sub
Or if you really interested in copy-paste values and format:
Sub Test()
Dim lr As Long, x As Long
With ThisWorkbook.Worksheets("Sheet1") 'Change accordingly
'Find last used row
lr = .Cells(.Rows.Count, 6).End(xlUp).Row
'Step through data
For x = 2 To lr Step 7
.Range(.Cells(x, 6), .Cells(x + 6, 7)).Copy
.Cells(x, 8).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Next x
End With
End Sub
Here's another solution:
Sub main()
Dim rngSrc As Range
Set rngSrc = Range("F2:G8")
While (rngSrc.Cells(1, 1).Value2 <> "")
transpose rngSrc
Set rngSrc = rngSrc.Offset(7, 0)
Wend
End Sub
Sub transpose(rngSrc As Range)
rngSrc.Copy
rngSrc.Cells(1, 2).Offset(0, 1).PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, SkipBlanks:=False, transpose:=True
End Sub
I have a table with data in a worksheet called 'DL data calculation'. I want to copy the highest row in the table (A21:E21) (after filtering) to (Y3:AC3). The problem I am facing right now is that when I declare the range try to filter, only the A21:E21 row of cells gets copied instead of the highest row. Can someone help me? I entered the script I used underneath.
Sub CopySelectionVisibleRowsEnd()
Dim ws As Worksheet
Dim mySel As Range
Dim lRow As Long
Dim lRowNew As Long
Dim lRowsAdd As Long
Dim myList As ListObject
Dim myListRows As Long
Dim myListCols As Long
Set ws = ActiveSheet
Set mySel = Selection.EntireRow
Set myList = ActiveCell.ListObject
myListRows = myList.Range.Rows.Count
myListCols = myList.Range.Columns.Count
lRow = ws.Cells.Find(What:="*", _
SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, _
LookIn:=xlValues).Row + 1
mySel.SpecialCells(xlCellTypeVisible).Copy
ws.Cells(lRow, 1).PasteSpecial Paste:=xlPasteAll
lRowNew = ws.Cells.Find(What:="*", _
SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, _
LookIn:=xlValues).Row + 1
lRowsAdd = lRowNew - lRow
With myList
.Resize ws.Range(.Range.Resize(myListRows + lRowsAdd, myListCols).Address)
End With
Application.CutCopyMode = False
End Sub
I made some changes to create sample data and working code:
Sub CreateSampleData()
Range("A21") = "F1"
Range("B21") = "F2"
Range("C21") = "F3"
Range("D21") = "F4"
Range("E21") = "F5"
Range("A22:E62") = "=INT(RAND()*1000)"
Range("A22:E62").Copy
Range("A22").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$21:$E$62"), , xlYes).Name = "Table1"
End Sub
Sub CopySelectionVisibleRowsEnd()
Dim ws As Worksheet
Dim mySel As Range
Dim lRow As Long
Dim lRowNew As Long
Dim lRowsAdd As Long
Dim myList As ListObject
Dim myListRows As Long
Dim myListCols As Long
Set ws = ActiveSheet 'Sheets("Tabelle1")
Why do you select this row?
You do want to select the first visible row here?
This line just selects the "EntireRow" of the active selection.
Set mySel = Selection.EntireRow
Let's continue with your code:
Set myList = ActiveCell.ListObject
myListRows = myList.Range.Rows.Count
myListCols = myList.Range.Columns.Count
lRow = ws.Cells.Find(What:="*", _
SearchOrder:=xlRows, _
SearchDirection:=xlNext, _
LookIn:=xlValues).Row + 1
'Here you copy the row of the active cell (if its visible).
'If you select a cell and make it unvisible with the filter
'you select nothing!
'mySel.SpecialCells(xlCellTypeVisible).Copy
'If you select a cell after the filter this can be copied with
'your code - first 5 cells only:
mySel.Range("A1:E1").SpecialCells(xlCellTypeVisible).Copy
' You want to paste to Cell Y3?
'ws.Cells(lRow, 1).PasteSpecial Paste:=xlPasteAll
ws.Range("Y3").PasteSpecial Paste:=xlPasteAll
'what is it that you want to achieve here?
lRowNew = ws.Cells.Find(What:="*", _
SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, _
LookIn:=xlValues).Row + 1
lRowsAdd = lRowNew - lRow
'I have no idea what you want to achieve here:
'With myList
'.Resize ws.Range(.Range.Resize(myListRows + lRowsAdd, myListCols).Address)
'End With
Application.CutCopyMode = False
End Sub
With the changes above at least the code was working.
Whatever row the cursor is manually placed in -> this row gets copied to the range "Y3:AC3"
With the below code I copy the first visible row (col A to E)
of the list existing on the active sheet and paste it to the
range (Y3:AC3).
Sub CopySelectionVisibleRowsEnd_NEW()
Dim myList As ListObject
Set myList = ActiveSheet.ListObjects(1) 'ActiveSheet.ListObjects("Table1")
Set CopyRange = myList.Range.Offset(1).SpecialCells(xlCellTypeVisible).Range("A1:E1")
CopyRange.Copy
Range("Y3").PasteSpecial Paste:=xlPasteAll
'or PasteValues:
'Range("Y3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
I'm trying to create a code that automatically creates a set-up that we use at work. I've gathered all the data in one column, and from there it has to copy the data in rows of 12 columns wide and every time he encounters the value 0PBSRC it has to start at a new row. what the result now is:
enter image description here
and this is what I want it to be:
enter image description here
this is the code I have now:
Sub EMCnaarTaq()
Dim Sheet1 As Worksheet
Dim Sheet2 As Worksheet
Dim rng As Range
Set Sheet1 = ThisWorkbook.Sheets("Mix Overzicht")
Set Sheet2 = ThisWorkbook.Sheets("Taqman Platen")
Set rng = Sheet1.Range("AI2:AI500")
For Each cel In rng
If cel.Value = "0PBS*RC*" Then
cel.Copy
' Worksheets("Taqman Platen").Cells(ActiveCell.Row, 8).Select
' ActiveCell.Offset(2, 0).Select
Range("H" & ActiveCell.Row + 2).Select
'Worksheets("Taqman Platen").Cells(Offset(2, 0), 8).Select
' Sheet2.Cells(Offset(2, 0), ActiveCell.Column).Select
GoTo Plakken
ElseIf cel.Value >= 1 Then
cel.Copy
Plakken:
Dim c
For Each c In Sheet2.Range("H3:S3,H5:S5,H7:S7,H9:S9,H11:S11,H13:S13")
If c = "" Then
c.Select
c.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False 'Select
Exit For
End If
Next
Else
End If
Next
End Sub
I know the problem is that when value 0pbsRC is met it goes to a new row, but it just keeps going back to the first blank cell in the range I selected.
I've tried a lot of things and I feel like I'm close but I just can't find that solution.
Regards,
Patrick
The way I'd handle this is to declare a second range to act as the target for pasting the data into, offsetting it one column each time
then when the 0PBSRC value is hit change the target address to the start of the next empty row and continue from there.
something like
set SourceRng = Range(AI1:AI500)
Set TargetRng = Range(H3)
for cel in Sourcerng
TargetRng = TargetRange.offset(0,1)
if TargetRng.column = 20 #column S or cel.value = 0PBSRC
TargetRng = Range("H" & TargetRange.row+2)
#do copy / paste here
next cel
#Chris Sampson this is the code i got now:
Set Sheet1 = ThisWorkbook.Sheets("Mix Overzicht")
Set Sheet2 = ThisWorkbook.Sheets("Taqman Platen")
Set SourceRng = Sheet1.Range("AI2:AI500")
Set TargetRng = Sheet2.Range("H3")
For Each cel In SourceRng
If cel.Value >= 1 Then
TargetRng = TargetRng.Offset(0, 1)
If TargetRng.Column = 20 Or cel.Value = "0PBS*RC*" Then
TargetRng = Range("H" & TargetRng.Row + 2)
cel.Copy
TargetRng.PasteSpecial
End If
End If
Next cel
I finally got it working, this is what is had become;
Dim Sheet1 As Worksheet
Dim Sheet2 As Worksheet
Dim SourceRng As Range
Dim TargetRng As Range
Set Sheet1 = ThisWorkbook.Sheets("Mix Overzicht")
Set Sheet2 = ThisWorkbook.Sheets("Taqman Platen")
Set SourceRng = Sheet1.Range("AI2:AI500")
Set TargetRng = Sheet2.Range("H1")
For Each cel In SourceRng
If cel.Value = "0PBS*RC*" Then
Range("H" & ActiveCell.Row + 2).Select
cel.Copy
ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False 'Select
ElseIf cel.Value >= 1 Then
ActiveCell.Offset(0, 1).Select
If ActiveCell.Column = 20 Then
Range("H" & ActiveCell.Row + 2).Select
Else
End If
cel.Copy
ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False 'Select
End If
Next cel
Thank you for your help!
I am trying to use a macro to copy an entire column of data but stop once it hits a 0 or blank as I only want the cells in the column that actually have data in them.
Edit:
Worksheets("C_Plan").Select
Range("O13").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy Worksheets("Summary").Select
Range("A4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
I forgot to mention i am pasting from 3 different worksheets and after i select the data in one worksheet, I need the second paste to start where the first paste left off. I have been using
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Try this and tell me if this works for you
Sub Test()
Dim R As Integer
Dim P As Integer
Dim ws2 As Worksheet
Dim ws As Worksheet
Set ws2 = Worksheets("Sheet2")
Set ws = Worksheets("Sheet1")
ws.Select
R = Range("O65536").End(xlUp).Row
ws.Range(Cells(1, 15), Cells(R, 15)).Select
Selection.Copy
ws2.Select
P = Range("A65536").End(xlUp).Row
ws2.Cells(P, 1).Offset(1, 0).Select
Selection.PasteSpecial
End Sub
This will select all the Cells in column O with a value and copy it and then paste it to the worksheet "summary" starting in the last cell in Column A with data.
Assuming you have the top-most cell of your column stored as startCell as Range I would do something like this:
dim endCell as Range
dim colRange as Range
set endCell = startCell ' Here's where you'll need startCell already!
While endCell <> "" And endCell <> "0"
set endCell = endCell.Offset(1) ' Move down the column
Loop
set colRange = Range(startCell, endCell)
' Now you can do with "colRange" as you please. Copy, paste etc.