Needed to write code for copy paste date in single column.
by means of that there are n numbers of columns and needed to paste those in single column.
code that i tried but not working well
Sub Macro4()
'
' Macro4 Macro
'
'
Range("C3").Select
Selection.Copy
Range("B4:B12").Select
ActiveSheet.Paste
Range("E3").Select
Application.CutCopyMode = False
Selection.Copy
Range("D4:D12").Select
ActiveSheet.Paste
Range("G3").Select
Application.CutCopyMode = False
Selection.Copy
Range("F4:F8").Select
ActiveSheet.Paste
Range("I3").Select
Application.CutCopyMode = False
Selection.Copy
Range("H4:H10").Select
ActiveSheet.Paste
Range("B4:C12").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet5").Select
Range("D2").Select
ActiveSheet.Paste
Sheets("Sheet4").Select
Range("D4:E12").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet5").Select
Range("D11").Select
ActiveSheet.Paste
Sheets("Sheet4").Select
Range("F4:G8").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet5").Select
Range("D20").Select
ActiveSheet.Paste
Sheets("Sheet4").Select
Range("H4:I10").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet5").Select
Range("D25").Select
ActiveSheet.Paste
End Sub
i am posting image to show you which type of input i have and what type of output i needed. please help me to crack it ...Thanks
Welcome to StackOverflow. And welcome to VBA. Please study the code example below. it will do what you described.
Option Explicit ' always use this statement
Sub LoopColumns()
' always identify and declare your worksheets
Dim WsS As Worksheet ' Source sheet
Dim WsD As Worksheet ' Destination sheet
Dim CopyRange As Range
Dim C As Long ' column number
Dim Rld As Long ' last row in WsD
Set WsS = ActiveSheet ' better identify the sheet by name
Set WsS = Worksheets("Sheet1") ' this is the sheet I used
Set WsD = Worksheets("Sheet5") ' better give the sheet a descriptive name
For C = 1 To 6 Step 2 ' select columns 1, 3 and 5 in turn
' specify the range starting in row 4 of the looped column
' and end at the end of that column, offset by 1
Set CopyRange = WsS.Range(WsS.Cells(4, C), _
WsS.Cells(WsS.Rows.Count, C).End(xlUp).Offset(0, 1))
' determine the row below the last used row in WsD
Rld = WsD.Cells(WsD.Rows.Count, 1).End(xlUp).Row + 1
If Rld < 3 Then Rld = 3 ' start from row 3 3
' paste to column A below the last used row
CopyRange.Copy Destination:=WsD.Cells(Rld, "A")
Next C
End Sub
Change the ranges and try:
Option Explicit
Sub test()
Dim LastRowCol As Long, LastRowOut As Long, i As Long, StartColumn As Long, Endcolumn As Long
StartColumn = 2
Endcolumn = 6
With ThisWorkbook.Worksheets("Sheet1")
For i = StartColumn To Endcolumn Step 2
LastRowCol = .Cells(.Rows.Count, i).End(xlUp).Row
LastRowOut = .Cells(.Rows.Count, "J").End(xlUp).Row
.Range(.Cells(4, i), .Cells(LastRowCol, i + 1)).Copy .Range("J" & LastRowOut + 1)
Next i
End With
End Sub
Result:
Related
I am a newbie and my macro is mix of recorded and written code , hence embarrassed
How Do I fill all blank cells In Column A and B with data below it as there are gaps and i am not able to fill the gaps or cannot think of any other way
Sub Macro4offsetselectionfinal()
Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Dim lr As Long
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Columns("C:D").Select
Selection.Copy
Columns("A:B").Select
ActiveSheet.Paste
Range("C1:E5").Select
Application.CutCopyMode = False
Selection.ClearContents
Set sht = Worksheets("00689")
Set StartCell = Range("A7")
'Find Last Row and Column
LastRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = sht.Cells(StartCell.Row, sht.Columns.Count).End(xlToLeft).Column
'Select Range
sht.Range(StartCell, sht.Cells(LastRow, LastColumn)).Select
Selection.AutoFilter Field:=5, Criteria1:="<>"
Range("A8:B8").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Rows("7:7").Select
Selection.AutoFilter
Range("B7").Select
Selection.End(xlDown).Select
Selection.Offset(-1).Select
ActiveCell.FormulaR1C1 = ActiveCell.Offset(1, 0).Value
Range("A7").Select
Selection.End(xlDown).Select
Selection.Offset(-1).Select
ActiveCell.FormulaR1C1 = ActiveCell.Offset(1, 0).Value
Range("A8").Select
lr = Range("A" & Rows.Count).End(xlUp).Row
Range("A8:A" & lr).SpecialCells(xlCellTypeBlanks).Select
Selection.SpecialCells(xlCellTypeBlanks).Select
ActiveCell.FormulaR1C1 = ActiveCell.Offset(1, 0).Formula
Application.CutCopyMode = False
Calculate
Range("A7").Select
End Sub
Using offset doesn't seem to work, can anyone advise
Thanks,
Jenny
enter image description here
If you wanted to fill the blanks with the values bellow, here is one version.
Sub FillTheBlanks()
Dim rng As Range
Set rng = Range("A7:B" & Cells(Rows.Count, "A").End(xlUp).Row)
rng.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[1]C"
rng.Value = rng.Value
End Sub
Before and after results
I am currently try to make a code that will format sheets 5 and on to module one's code and then have the program copy all the information in each of those newly formatted sheets and paste them into "sheet3" with original width and format.
I have tried the "for each" and "integer" functions but can't seem to get 'the program to move past "sheet5".
This sub is suppose to go through all of the sheets and and 'format them to my needs:
Sub TEST2()
Dim ws As Worksheet
Dim wsDest As Worksheet
Dim LastRow As Long
Set wsDest = Sheets("sheet3")
For Each ws In ActiveWorkbook.Sheets
If ws.Name <> wsDest.Name And _
ws.Name <> "sheet1" And _
ws.Name <> "sheet2" And _
ws.Name <> "sheet4" Then
'code here
Columns.Range("A:A,B:B,H:H,I:I").Delete
Columns("A").ColumnWidth = 12
Columns("B").ColumnWidth = 17
Columns("C").ColumnWidth = 10
Columns("D").ColumnWidth = 85
Columns("E").ColumnWidth = 17
ActiveSheet.Range("D:D").WrapText = True
ActiveSheet.Range("F:F").EntireColumn.Insert
ActiveSheet.Range("F1").Formula = "Product ID"
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("F2:F" & LastRow).Formula = "=$G$2"
ActiveSheet.Range("F2").Copy
Range("F2:F" & LastRow).PasteSpecial Paste:=xlPasteValues
End If
Next ws
End Sub
This sub is meant to go to "sheet5" first and paste it into '"sheet3", than the second half of the sub should start at "sheet6" and go on 'until the end of the work sheets and then copy & paste onto "sheet3" with 'original width.
Sub Test1()
Dim sht As Worksheet
Dim LastRow As Long
Dim WS_Count As Integer
Dim I As Integer
Sheets("Sheet5").Select
Application.CutCopyMode = False
Application.Run "PERSONAL.XLSB!Module1.Del_move_insert_colmuns"
Range("G2").Select
ActiveCell.Offset(0, -1).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("A1").Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Range("D:D").WrapText = True
WS_Count = ActiveWorkbook.Worksheets.Count
' Begin the loop
For I = 5 To WS_Count
'code here
Sheets("Sheet6").Select
Application.Run "PERSONAL.XLSB!Module1.Del_move_insert_colmuns"
Application.CutCopyMode = False
Range("G2").Select
ActiveCell.Offset(0, -1).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).SelectApplication.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("A1").Select
'crtl shift + down
Selection.End(xlDown).Select
'moves down one cell to paste
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Next I
End Sub
What im getting right now is it does "sheet5" and "sheet6" fine,but after that doesn't format and on sheet there all i get is a bunch of columns with top labeled as product ID and a bunch of 0's.
A big part of your problem is that most of your code is "assuming" that you are working with a certain worksheet when you're really working with the ActiveSheet. As an example in your TEST2 routine, you're looping through all of the worksheets in the workbook, skipping certain sheets. This part works fine. But when you want to format the other sheets, you're really only working with whatever worksheet is currently active. To fix this, you should make a habit of making sure all of your Worksheet, Range, and Cells reference are always fully qualified. So then your code works like this:
ws.Columns.Range("A:A,B:B,H:H,I:I").Delete
ws.Columns("A").ColumnWidth = 12
ws.Columns("B").ColumnWidth = 17
ws.Columns("C").ColumnWidth = 10
ws.Columns("D").ColumnWidth = 85
ws.Columns("E").ColumnWidth = 17
ws.Range("D:D").WrapText = True
ws.Range("F:F").EntireColumn.Insert
ws.Range("F1").Formula = "Product ID"
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
ws.Range("F2:F" & LastRow).Formula = "=$G$2"
ws.Range("F2").Copy
ws.Range("F2:F" & LastRow).PasteSpecial Paste:=xlPasteValues
Notice how every single reference is locked to the same worksheet. You can take a shortcut though, by using the With statement. But you must make sure that each reference has the . in front of it to lock it back to the With object, like this:
With ws
.Columns.Range("A:A,B:B,H:H,I:I").Delete
.Columns("A").ColumnWidth = 12
.Columns("B").ColumnWidth = 17
.Columns("C").ColumnWidth = 10
.Columns("D").ColumnWidth = 85
.Columns("E").ColumnWidth = 17
.Range("D:D").WrapText = True
.Range("F:F").EntireColumn.Insert
.Range("F1").Formula = "Product ID"
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("F2:F" & LastRow).Formula = "=$G$2"
.Range("F2").Copy
.Range("F2:F" & LastRow).PasteSpecial Paste:=xlPasteValues
End With
For the rest of your code, you can make improvements by avoiding the use of Select and Activate. Consider also the tips discussed in this article that will give you excellent guidance.
I have 4 sheets in my workbook . I want to combine all the data in new worksheet . I got the code which I written below. But now I don't want to display sheet1 data in new sheet. Have attached the worksheet for your reference . Thanks in Advance!!!!
sub Combine()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Combined"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
End Sub
Only minor changes to your code will make this work:
Sub Combine()
Dim Lastrow As Integer
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Combined"
Sheets(3).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 3 To Sheets.Count
Sheets(J).Activate
' First delete the empty rows
Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:L" & Lastrow).Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
' Then select the region as a table
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
End Sub
I am trying to get data from every other sheet in the workbook and paste it into a master sheet (Sheet1), but when I run my code nothing happens, Can someone tell me why this is?
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
wb.Sheets("Sheet1").Cells(1, 1).Text = "Started"
i = 1
'cells is row,col
For Each objWorksheet In wb.Worksheets
'ws.Cells(1, i).Value = objWorksheet.Name
'objWorksheet.Activate
'ws = wb.ActiveSheet
doJStuff i, objWorksheet
i = i + 1
Next
wb.Sheets("Sheet1").Cells(1, 1).Text = "DONE"
End Sub
Sub doJStuff(row, ws)
ws.Select
Range("A2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Cells(row, 1).Select
ActiveSheet.Paste
'end paste name
'copy post history and transpose into row 2 on sheet1
ws.Select
Range("H2:H30").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Cells(row, 2).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
'end post history
End Sub
You've got a number of problems with your code. First of all, avoid using Select wherever possible. Second, you are not properly assigning variables. You should put Option Explicit on the top of the module and then make sure you've assigned things correctly.
As for the actualy code, when you are copying/pasting the H2:H30 range into your first sheet you are going to only end up getting the first value in the range for every sheet except the last because you are pasting 28 rows but only incrementing the destination row by one. I didn't fix that but it's worth pointing out. I also left in your comments though they don't make much sense. Without knowing what you are trying to do, I've only cleaned up some of your code but it probably still won't work exactly right.
Sub YourSub()
Dim wb As Workbook
Dim wksht As Worksheet
Dim i As Integer
Set wb = ActiveWorkbook
wb.Sheets("Sheet1").Cells(1, 1).Text = "Started"
i = 1
'cells is row,col
For Each wksht In Worksheets
'ws.Cells(1, i).Value = objWorksheet.Name
'objWorksheet.Activate
'ws = wb.ActiveSheet
doJStuff i, wksht
i = i + 1
Next
wb.Sheets("Sheet1").Cells(1, 1).Text = "DONE"
End Sub
Sub doJStuff(row As Integer, ws As Worksheet)
ws.Range("A2").Copy
Sheets("Sheet1").Cells(row, 1).PasteSpecial
'end paste name
'copy post history and transpose into row 2 on sheet1
ws.Range("H2:H30").Copy
Sheets("Sheet1").Cells(row, 2).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
'end post history
End Sub
I am trying to write a macro to get the result as shown in the figure below:
From: To:
abc.a#xxx.com aaa.b#xxx.com,bbb.a#xxx.com
I want it in this form:
From To
aaa.a aaa.b
aaa.a bbb.a
But the Macro code(described below) writes everything under column 'A', which I don't want.
Please help me to correct the following Macro code so that I get the result as in the image shown.
Macro Code:
Sub Macro2()
Dim LR As Long, Rw As Long
Dim wsDATA As Worksheet, wsNEW As Worksheet
Set wsDATA = ActiveSheet
Set wsNEW = Sheets.Add
LR = wsDATA.Range("A" & Rows.Count).End(xlUp).Row
For Rw = 2 To LR
wsDATA.Rows(Rw).SpecialCells(xlConstants).Copy
wsNEW.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteAll, Transpose:=True
Next Rw
Range("A4").Select
ActiveWindow.SmallScroll Down:=-3
Application.Run "'email headers.csv'!Macro2"
ActiveWindow.SmallScroll Down:=-15
Columns("A:A").EntireColumn.AutoFit
ActiveWindow.SmallScroll Down:=-30
Sheets("Sheet1").Select
Application.WindowState = xlNormal
Range("B3").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "First.Last#company.com"
Range("A1").Select
Sheets("Sheet2").Select
Range("A8").Select
End Sub
Thanking you in advance for your help.
This part of the code is attempting to paste the data in the next available row of column A:
wsNEW.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteAll, Transpose:=True
What you want to do is find the next available column in row 1 (presumably), and paste there, and since you're not transposing, you can omit that parameter (or set it to False, which is the default.
Assuming you're starting with an empty worksheet:
For Rw = 2 To LR
wsDATA.Rows(Rw).SpecialCells(xlConstants).Copy
wsNEW.Cells(1, Rw-1).PasteSpecial xlPasteAll, Transpose:=False
Next Rw
Assuming you're starting with a sheet which may contain data already, and that row 1 is a reasonably proxy for whether any particular column has data:
For Rw = 2 To LR
wsDATA.Rows(Rw).SpecialCells(xlConstants).Copy
wsNEW.Cells(1, wsNew.Columns.Count).End(xlToLeft).Offset(,1).PasteSpecial xlPasteAll, Transpose:=False
Next Rw