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
Related
I have the following set of code to record daily employees who eat lunch in the canteen. What change is needed so that when the person clicks on the macro button every day, the data is on the 1st blank line (from column A) of the "dados_diarios" sheet?
This is so that at the end of the month I have a list of all the days.
Sub outros_diario()
Sheets("outros").Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Workbooks.Open ("N:\RH\Cantina\Lista_OUTROS.xlsx")
Windows("Lista_OUTROS.xlsx").Activate
Cells.Select
Selection.Copy
Windows("outros.xlsm").Activate
Sheets("outros").Select
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
ActiveWindow.DisplayGridlines = False
Range("B8:O1000").Select
Selection.Copy
Sheets("dados_diarios").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("C2:F1000").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("E2:H1000").Select
Selection.Delete Shift:=xlToLeft
Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
Range("H8").Select
Columns("C:C").EntireColumn.AutoFit
End Sub
Give this a go. You may want to add back in your DisplayGridlines= False and the deletion of cells at the end - but it should give you a much better start than where you're up to right now:
Sub outros_diario()
'declarations
Dim last_row_source As Long
Dim last_row_destination As Long
Dim source_book As Workbook
Dim source_sheet As Worksheet
Dim dest_sheet1 As Worksheet
Dim dest_sheet2 As Worksheet
'set references to the two paste destinations
Set dest_sheet1 = ThisWorkbook.Sheets("outros")
Set dest_sheet2 = ThisWorkbook.Sheets("dados_diarios")
'delete-clear sheet: outros
dest_sheet1.Cells.Delete Shift:=xlUp
'open the workbook as reference 'source_book'
Set source_book = Workbooks.Open("N:\RH\Cantina\Lista_OUTROS.xlsx")
'set a reference to the activesheet and call it 'source_sheet'
Set source_sheet = source_book.ActiveSheet
'copy source_sheet to dest_sheet1 [outros]
source_sheet.Cells.Copy dest_sheet1.Range("A1")
'find where the data now stops on the [outros]
last_row_source = dest_sheet1.Cells(dest_sheet1.Rows.Count, "B").End(xlUp).Row
'find where the data stops on [dados_diarios]
last_row_destination = dest_sheet2.Cells(dest_sheet2.Rows.Count, "B").End(xlUp).Row
'copy data values from [outros] to [dados_diarios] ignoring first 7 rows
dest_sheet2.Range("A" & last_row_destination + 1).Resize(last_row_source - 7, 14).Value = dest_sheet1.Range("B8:O" & last_row_source).Value
'close the source workbook, without saving
source_book.Close False
End Sub
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:
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 want to copy data in certain cells to another sheet in a table.
My code copies the data and searches for the cell to be pasted to. If there is a value in the destination cell, it is looped to check the subsequent rows in the same column until it finds an empty cell.
If there's 2000 rows of data currently in the table, it will search all 2000 cells before landing in the 2001st row.
The amount of time taken to execute the code is affected by the size of the table.
Is there any way to execute faster?
Below is a sample, its copying data from two cells.
Sub Test()
Sheets("Sheet1").Select
Range("K10").Select
Selection.Copy
Sheets("Table").Select
Range("A2").Select
Do While Not (ActiveCell.Value = "")
ActiveCell.Offset(1, 0).Activate
Loop
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("Sheet1").Select
Range("G15").Select
Selection.Copy
Sheets("Table").Select
Range("B2").Select
Do While Not (ActiveCell.Value = "")
ActiveCell.Offset(1, 0).Activate
Loop
End sub
Try following sub.
Sub CopyPaste()
Dim sht1, sht2 As Worksheet
Set sht1 = Worksheets("Sheet1")
Set sht2 = Worksheets("Table")
sht1.Range("K10").Copy sht2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
sht1.Range("G15").Copy sht2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
End Sub
It's unclear on whether you expect to find interim blank cells within the worksheet's used range or whether you expect to always put the new values at the bottom of the used range. This should work for both scenarios.
Sub Test()
Dim ws1 As Worksheet
Set ws1 = Worksheets("sheet1")
With Worksheets("table")
'force a definition for a .UsedRange on the worksheet
.Cells(.Rows.Count, "A") = Chr(32)
.Columns(1).SpecialCells(xlCellTypeBlanks).Cells(1) = ws1.Cells(10, "K").Value
.Columns(1).SpecialCells(xlCellTypeBlanks).Cells(1) = ws1.Cells(15, "G").Value
'clear the artificial .UsedRange
.Cells(.Rows.Count, "A").Clear
'Debug.Print .UsedRange.Address(0, 0)
End With
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