I have the code below and it all works well with MyCopy10. But the next code MyCopy100 is not copying the data in last row of sheet Actual Email. I am not sure as were problem is.
here is my Code:
Sub MyCopy10()
Dim myCols As Variant
Dim lastRow As Long
Dim c As Long
Sheets("Eamil-10").Activate
'Set columns you want to loop through in an array
myCols = Array("A", "B", "C", "D")
' Loop through columns array
For c = LBound(myCols) To UBound(myCols)
' Find last row in column A with data
lastRow = Sheets("Eamil-10").Cells(Rows.Count, myCols(c)).End(xlUp).Row
' Copy data from Model sheet to summary sheet
Sheets("Eamil-10").Range(Cells(1, myCols(c)), Cells(lastRow,
myCols(c))).Copy
Sheets("Actual Email").Cells(1, c + 1).PasteSpecial Paste:=xlValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Next c
' Sheets("Summary").Activate
End Sub
Code:
Sub MyCopy100()
Dim myCols As Variant
Dim lastRow As Long
Dim c As Long
Sheets("Email-100").Activate
' Set columns you want to loop through in an array
myCols = Array("A", "B", "C", "D")
' Loop through columns array
For c = LBound(myCols) To UBound(myCols)
' Find last row in column W with data
lastRow = Sheets("Email-100").Cells(Rows.Count, myCols(c)).End(xlUp).Row
' Copy data from Model sheet to summary sheet
Sheets("Email-100").Range(Cells(1, myCols(c)), Cells(lastRow,
myCols(c))).Copy
Sheets("Actual Email").Cells(1, c + 1).PasteSpecial Paste:=xlValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Next c
' Sheets("Summary").Activate
End Sub
Try the code below, all Range and Cells are qualified with Sheets("Email-100").
Code
Option Explicit
Sub MyCopy100()
Dim myCols As Variant
Dim lastRow As Long
Dim c As Long
' Set columns you want to loop through in an array
myCols = Array("A", "B", "C", "D")
With Sheets("Email-100")
' Loop through columns array
For c = LBound(myCols) To UBound(myCols)
' Find last row in column with data
lastRow = .Cells(.Rows.Count, myCols(c)).End(xlUp).Row
' Copy data from Model sheet to summary sheet
.Range(.Cells(1, myCols(c)), .Cells(lastRow, myCols(c))).Copy
Sheets("Actual Email").Cells(1, c + 1).PasteSpecial Paste:=xlValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Next c
End With
End Sub
Related
I want to do lookup in a specified range(rows X to AF in "main" tab[Sheet1]) which I am doing using VBA hlookup function. The problem I am facing is that I am not able to do this lookup in a loop, which means once the hlookup is done in X2:AF2, then it should do the calculation in X3:AF3 for next row.
I need to do this because the Tablehandle[sheeet2] result will change every time (macro will clear this sheet) and the headers will not in order.
So can someone help me to get hlookup in a loop for a specified row?
My "Main" sheet
"TableHandle" sheet
Option Explicit
Sub hlookup1()
Dim i, r As Long
For i = 1 To Range("K100000").End(xlUp).Row - 1
'first macro will get the table inside sheet ...
Sheets("TableHandle").Select
'Range("A2").Select
'Range(Selection, Selection.End(xlDown)).Select
'Range("A2:B10").Select
'Selection.Copy
Range("F1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
'hlookup
Sheets("Main").Select
Range("X2").Select
Range("X" & i + 1).Select
ActiveCell.FormulaR1C1 = "=HLOOKUP(R1C,TableHandle!R1C6:R2C14,2,0)"
Selection.Copy
Range("X2:AF2").Select 'PROBLEM from Here, it will again calculate in x2 to af2 range)
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells.Replace What:="#N/A", Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
i = i + 1
Next
End Sub
Yours is a good idea but in practice it has a number of drawbacks as demonstrated by the error handling you had planned. I think you would also have to replace the formulas you insert with so much effort with the values they produce. Please try this code instead. It transfers data from the TableHandler sheet to the Main without the use of worksheet formulas.
Sub hlookup1()
' 211
Dim Data As Variant ' source data
Dim Headers As Range ' column captions in 'Main'
Dim Fnd As Range ' Find the column caption
Dim Rs As Long ' Row: Source (= 'Data')
Dim Cs As Long ' Column: Source
Dim Rt As Long ' Row: Target
Dim Ct As Long ' Column: Target
'first macro will get the table inside sheet ...
With Worksheets("TableHandle") ' data source
Rs = .Cells(.Rows.Count, "A").End(xlUp).Row
Data = .Range(.Cells(2, "A"), .Cells(Rs, "X")).Value
' Row 1 of 'Data' holds the column headers because
' SheetRow(2) became the ArrayRow(1)
End With
Application.ScreenUpdating = False ' speed up execution
With Worksheets("Main")
Set Headers = .Range("A2:X2")
' start in array row 2 because array row 1 holds the column captions
For Rs = 2 To UBound(Data) ' loop through all rows
Rt = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
For Cs = 1 To UBound(Data, 2) ' loop through the columns of each row
Set Fnd = Headers.Find(Data(1, Cs), LookIn:=xlValues, lookat:=xlWhole)
If Not Fnd Is Nothing Then ' skip column not found
.Cells(Rt, Fnd.Column).Value = Data(Rs, Cs)
End If
Next Cs
Next Rs
End With
Application.ScreenUpdating = True
End Sub
If a column in the TableHandler should not be found the macro will not transfer data, leaving the target column blank. If you want a warning it would have to be added. There is a little confusion in your question as to rows and columns. Should I have guessed wrongly here or there I trust you will be able to make the required modifications. However, you are welcome to ask for help, too.
it was important and i spent all day to make this possible, i ans my question here.
the code is shortned as below, it works fast and efficient. thanks for suggestions!
Dim Hlookp As Variant
Hlookp = Application.HLookup(Range("B1:J1").Value, Sheets("TableHandle").Range("F1:N" & Cells(Rows.Count, 1).End(xlUp).row), 2, False)
Range("B" & i + 1 & ":J" & i + 1).Value = Hlookp
I am not sure sure what I am doing wrong in trying to copy a range from one worksheet to another. Trying to copy from "LeadSheet" to "HistoricalDataSheet". Leadsheet Data will always start with Row 5 and copy the full rows until the last row. Then paste into the row after the last row on "HistoricalDataSHeet" and format the first column for date:
Sub CopyToHistorical()
Dim a, LR As Integer
With Worksheets("LeadSheet")
LR = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
With Worksheets("LeadSheet")
**.Range("5:LR").Copy**
'this is where I am getting there error'
End With
With Worksheets("HistoricalLeadData")
a = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
Sheets("HistoricalLeadData").Range("A" & a + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
With Sheets("HistoricalLeadData")
.Range(.Range("A" & a + 1), .Range("A" & a + 1).End(xlDown)).NumberFormat = "m/d/yyyy"
End With
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:
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
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