I would like to create a VBA, to copy my data in "RAW", to paste into sheet "summary" by the specific column arrangement in my "summary" sheet.
for example, if sheet "summary" column A is COUNTER CODE, then copy the data from sheet "RAW" which the data is in B2-B5 and paste into my sheet "summary" A2-A5
I tried to use the below VBA, which it works. but in the event if the column data in "RAW" is different, i will not be getting the correct data.
Sub TRANSFERDATA()
Dim LASTROW As Long, EROW As Long
LASTROW = Worksheets("RAW").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LASTROW
Worksheets("RAW").Cells(i, 1).Copy
EROW = Worksheets("summary").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("RAW").Paste Destination:=Worksheets("summary").Cells(EROW + 1, 2)
Worksheets("RAW").Cells(i, 2).Copy
Worksheets("RAW").Paste Destination:=Worksheets("summary").Cells(EROW + 1, 1)
Worksheets("RAW").Cells(i, 3).Copy
Worksheets("RAW").Paste Destination:=Worksheets("summary").Cells(EROW + 1, 4)
Worksheets("RAW").Cells(i, 4).Copy
Worksheets("RAW").Paste Destination:=Worksheets("summary").Cells(EROW + 1, 3)
Next i
End Sub
Thanks!
summary
RAW
Test the next code, please. Yo do not have to copy cell by cell. In the way the code is designed, it will also work for a header which is not identic with the one in 'RAW' worksheet, but 'RAW' header string is contained:
Sub TestFindCopyInPlace()
Dim shR As Worksheet, shSum As Worksheet, colHeadR As String
Dim colHS As Range, lastCol As Long, lastRow As Long, i As Long
Set shR = Worksheets("RAW")
Set shSum = Worksheets("summary")
lastCol = shR.Cells(1, Columns.count).End(xlToLeft).Column
lastRow = shR.Range("A" & Rows.count).End(xlUp).Row
For i = 1 To lastCol
colHeadR = shR.Columns(i).Cells(1, 1).value
Set colHS = shSum.Rows(1).Find(colHeadR)' find the cell with the header of the one being copied
If Not colHS Is Nothing Then 'Find method will find a column containing colHeadR in its header string...
shR.Range(shR.Cells(2, i), shR.Cells(lastRow, i)).Copy Destination:=colHS.Offset(1, 0)
Else
MsgBox "The column header """ & colHeadR & """ could not be found." & vbCrLf & _
"Please check the spelling or whatever you think it is necessary..."
End If
Next i
End Sub
The code should work for as many columns your 'RAW` worksheet contains...
To make the process fully automatic, please use the following code:
Sub TRANSFERDATA()
Const rawSheet As String = "RAW"
Const summarySheet As String = "summary"
'===================================================================================
' Find the last column in both sheets
'===================================================================================
Dim rawLastCol As Integer
Dim summaryLastCol As Integer
rawLastCol = Worksheets(rawSheet).Cells(1, Columns.Count).End(xlToLeft).Column
summaryLastCol = Worksheets(summarySheet).Cells(1, Columns.Count).End(xlToLeft).Column
'===================================================================================
' Iterate over all columns in the RAW sheet and transfer data to the summary sheet
'===================================================================================
Dim col As Integer
For col = 1 To rawLastCol
'Read column header
Dim header As String
header = Worksheets(rawSheet).Cells(1, col).Value
'Find this header in the summary sheet
Dim col2 As Integer
For col2 = 1 To summaryLastCol
If Worksheets(summarySheet).Cells(1, col2).Value = header Then
'Transfer all values from RAW to the summary sheet
Dim lastRow As Integer
lastRow = Worksheets(rawSheet).Cells(Rows.Count, col).End(xlUp).row
If lastRow > 1 Then 'to handle the case where a column contains no data
'First clear previous data
Range(Worksheets(summarySheet).Cells(2, col2), Worksheets(summarySheet).Cells(lastRow, col2)).ClearContents
'Now, transform data
Dim row As Integer
For row = 2 To lastRow
Worksheets(summarySheet).Cells(row, col2).Value = Worksheets(rawSheet).Cells(row, col).Value
Next row
End If
'Break
Exit For
End If
Next col2
Next col
End Sub
This will work event if the number of columns or rows change in your sheets
Related
Two questions:
1) I have a spreadsheet (TC) that has data on one page that will be updated daily. There are 28 columns. Essentially I am looking to have the line (row) data cut and paste into a second spreadsheet (Archive) when Col. 28 has a value entered in it. I have the base coding but for some reason it causes Excel to be non-responsive.
I think it might be because the coding goes cell by cell rather than row by row. Can anyone point me in the right direction? (Again, keep in mind, this is a snippet of the coding - I have each Cut and Paste up to Column 28.)
2) The second part of my question is: Will what I have written make sure that when the Command Button is pressed next time, the data will cut and paste to the next blank line. Thank you!
Private Sub CommandButton1_Click()
a = Worksheets("TC").Cells(Rows.Count, 2).End(xlUp).Row
'Dim rng As Range
'Set rng = Worksheets("Archived").Range("A1")
b = 1
For i = 2 To a
If Worksheets(“TC”).Cells(i, 28).Value <> "" Then
'Change # to be the number column of Pt Name
Worksheets(“TC”).Cells(i, 1).Cut
'Change ,# to be the number column of where you want it pasted.
Worksheets(“TC”).Paste Destination:=Worksheets(“Archive”).Cells(b + 1, 1)
'Change ,# to be the number column of SOC
Worksheets(“TC”).Cells(i, 2).Cut
'Change ,# to be the number column of where you want it pasted.
Worksheets(“TC”).Paste Destination:=Worksheets(“Archive”).Cells(b + 1, 2)
b = b + 1
End If
Next
Application.CutCopyMode = False
ThisWorkbook.Worksheets(“TC”).Cells(1, 1).Select
End Sub
You can do something like this:
Private Sub CommandButton1_Click()
Dim i as long, b As Long, shtTC as worksheet, shtArch as worksheet
Set shtTC = Worksheets("TC")
Set shtArch = Worksheets("Archive")
'find the first empty row
b = shtArch.Cells(Rows.Count, 2).End(xlUp).Row + 1 'pick a column which will always be populated
For i = 2 To shtTC.Cells(Rows.Count, 2).End(xlUp).Row
If shtTC.Cells(i, 28).Value <> "" Then
'cut the row
shtTc.Cells(i, 1).Resize(1, 28).Cut shtArch.Cells(b, 1)
b = b + 1
End If
Next
Application.CutCopyMode = False
shtTC.Cells(1, 1).Select
End Sub
Here's an example of how to create the kind of copy results you're looking for. Notice that, unless you specifically want to copy/paste all of the formatting with the data, you don't need to use copy/paste. You can perform the copy by assigning the values of the ranges.
Option Explicit
Private Sub CommandButton1_Click()
CopyData ThisWorkbook.Sheets("TC"), ThisWorkbook.Sheets("Archived")
End Sub
Public Sub CopyData(ByRef source As Worksheet, _
ByRef dest As Worksheet, _
Optional ByVal deleteSource As Boolean = False)
'--- calculate and create the source data range
Const TOTAL_COLUMNS As Long = 1
Dim srcRange As Range
Dim lastRow As Long
With source
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set srcRange = .Range("A1").Resize(lastRow, TOTAL_COLUMNS)
End With
'--- determine where the data should go
Dim destRange As Range
With dest
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If lastRow > 1 Then lastRow = lastRow + 1
Set destRange = .Cells(lastRow, 1)
Set destRange = destRange.Resize(srcRange.Rows.Count, TOTAL_COLUMNS)
End With
'--- now copy the data
destRange.Value = srcRange.Value
'--- optionally delete the source data
If deleteSource Then
srcRange.Clear
End If
End Sub
I am brand-new to VBA.
I have two worksheets in the same workbook. The first worksheet, shStudentInfo, contains all of the information for each of my students, one row per StudentID (B4 in the code). The second worksheet, shSchedData, contains their schedules where there may be 0-14 rows per StudentID, depending on how many courses each student is taking.
I am attempting to use a loop and VLOOKUP with a dynamic range to extract the course name from each row of shSchedData and copy it to the appropriate cell in shStudentInfo, then move down one row. Currently I've hardcoded cell "CO4" as the appropriate cell although I will also need to make that reference move one cell to the right for each pass through the loop.
Here is my inelegant code:
Option Explicit
Dim MyRow As Long
Sub StudentSchedules()
Dim EndRow As Long
Dim MyRng As Range
shSchedData.Activate
'hard code first row of data set
MyRow = 3
'dynamic code last row of data set
EndRow = shSchedData.Range("A1048575").End(xlUp).Row
'create a dynamic range, a single row from shSchedData
Set MyRng = ActiveSheet.Range(Cells(MyRow, 1), Cells(MyRow, 9))
'Loop through entire data set one line at a time
Do While MyRow <= EndRow
shSchedData.Select
MyRng = ActiveSheet.Range(Cells(MyRow,1),Cells(MyRow,9))
shStudentInfo.Select
'Import course name from shSchedData worksheet
Range("CO4").Select
ActiveCell.Clear
ActiveCell.Formula = "=VLOOKUP(B4,'Schedule Data'!& MyRng,6,0)"
'The above line results in a #NAME? error in CO4 of shStudentInfo
'Also tried:
'ActiveCell.Formula = "=VLOOKUP(B4,'Schedule Data'!& MyRng.Address,6,0)"
'increment counter
MyRow = MyRow + 1
Loop
End Sub
The following rewrite will get your code working to the extent that its purpose can be determined.
The VLOOKUP formula does not appear correct and in any event, there might be a better method of retrieving the data. However, I cannot determine your end purpose from your narrative or code. Sample data together with expected results would help.
Option Explicit
'I see no reason to put this here
'dim myRow As Long
Sub StudentSchedules()
Dim myRow, endRow As Long, myRng As Range
'no need to activate, just With ... End With block it
With shSchedData
'assigned a strarting value
myRow = 3
'dynamic code last row of data set
endRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop through entire data set one line at a time
Do While myRow <= endRow
'create a dynamic range, a single row from shSchedData
Set myRng = .Range(.Cells(myRow, 1), .Cells(myRow, 9))
'Import course name from shSchedData worksheet
shStudentInfo.Range("CO4").Offset(0, myRow - 3).Formula = _
"=VLOOKUP(B4, " & myRng.Address(external:=True) & ", 6, false)"
'increment counter
myRow = myRow + 1
Loop
End With
End Sub
I came up with this, see if it fits you
Dim a As Double
Dim b As Double
Dim ml As Worksheet
Dim arrayrng As Variant
Dim i As Integer
Dim x As String
Dim y As String
Set ml = Worksheets("Master Data")
a = ml.Cells(Rows.Count, 11).End(xlUp).Row
b = ml.Cells(Rows.Count, 1).End(xlUp).Row
For i = a To b - 1
a = ml.Cells(Rows.Count, 11).End(xlUp).Row
b = ml.Cells(Rows.Count, 1).End(xlUp).Row
arrayrng = "E" & a + 1
x = "=VLOOKUP(" & arrayrng
y = ",'Data Base'!I:J,2,0)"enter code here
Range("K" & a + 1) = x + y
Next
I have a vba code that copies rows on a sheet to another sheet depending if column A = 1 and it works perfectly. I am trying to make it paste to the next available row instead of overwriting the data that is already there in order to make a log. Here is the code I have already but I can't seem to figure out how to make it paste to the next available row. Any help would be greatly appreciated! Thanks in advance!
Sub Log()
Dim rng As Range
Dim lastRow As Long
Dim cell As Variant
Dim count As Long
count = 0
With ActiveSheet
lastRow = .Range("A" & .Rows.count).End(xlUp).Row
Set rng = .Range("A3:A" & lastRow)
For Each cell In rng
If cell.Value = "1" Then
Range(cell.Offset(0, 1), cell.Offset(0, 6)).Copy
Range("'Log'!B3").Offset(count, 0).PasteSpecial xlPasteValues
count = count + 1
End If
Next
End With
End Sub
You just need to loop through the source sheet.
Try using .Cells(row,col) instead of Range..
This example is heavy on the comments to help understand the looping process.
You will need a few additional Functions to make this work using this code.
LastRow Function
Function lastRow(sheet As String) As Long
lastRow = Sheets(sheet).Cells(Rows.Count, "A").End(xlUp).Row 'Using Cells()
End Function
LastCol Function
Function lastCol(sheet As String) As Long
lastCol = Sheets(sheet).Cells(2, Columns.Count).End(xlToLeft).Column
End Function
Code for solution: Assuming you have your target sheet's headers already set up AND the target and source sheet share the same formatting.
Sub Log()
Dim source As String, target As String
Dim sRow As Long, col As Long, tRow As Long
'Declare Sheets
source = "Sheet1"
target = "Sheet2"
'Loop through rows of source sheet
For sRow = 2 To lastRow(source)
'Get current last row of Target Sheet
tRow = lastRow(target) + 1
'Meet criteria for Column A to = 1 on Source
If Sheets(source).Cells(sRow, 1) = "1" Then
'Copy each column of source sheet to target sheet in same order
For col = 1 To lastCol(source)
Sheets(target).Cells(tRow, col) = Sheets(source).Cells(sRow, col)
Next col
End If
Next sRow
End Sub
I found this Excel VBA code that's very short and clean and it does its job to copy the entire row based on a condition. I added it to my vba project and it works well the only problem is - it copies the entire row.
I am trying to implement the code to only copy rows from Column E to K, but
I have not been successful in tweaking the code to what I am trying to do.
Basically, in worksheet "verification" if Column "AB" = "Final" then copy each row that has "Final" from Column E to K to the worksheet "upload".
I am pulling my hair to make it work, and I have search everywehre and no luck. I know in this platform, I can find the solution to my problem.
I will keep on playing with the code.
Sub CopyEachRowtoUpload()
Application.ScreenUpdating = False
Dim wsI As Worksheet, wsO As Worksheet
Dim LastRow As Long, i As Long, j As Long
Dim LastColumn As Long, a As Long, b As Long
Dim rng As Range
Set wsI = Sheets("Verification")
Set wsO = Sheets("Upload")
Set rng = wsI.Range("E:K")
'Last Row in a Column. Row need to start in row 2
LastRow = wsI.Cells(Rows.Count, "K").End(xlUp).Row
'Last Column in a Row. Rows from Column E to K is what I want to copy
LastColumn = wsI.Cells(5, Columns.Count).End(xlToLeft).Column
'Row start
j = 2
With wsI
'Loop through each row
For i = 1 To LastRow
If Range("AB" & i).Value = "Final" Then
wsI.Rows(i).Copy
wsO.Rows(j).PasteSpecial Paste:=xlPasteValues
j = j + 1
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Just use the Range.Cells property together with the Range.Resize property to locate and shape the source and target.
With wsI
'Loop through each row
For i = 1 To LastRow
If .Range("AB" & i).Value = "Final" Then
wsO.Cells(j, "A").Resize(1, 7) = .Cells(i, "E").Resize(1, 7).Value
j = j + 1
End If
Next i
End With
Direct value transfer is preferred over Copy, Paste Special, Values if all you want is the cell values.
btw, you were missing a . in .Range("AB" & i).Value.
I have a row of cells (the row elements may vary) and another sheet with several columns of data. Let's say on sheet 1 we have 7 columns with data(first column with titles) and on sheet 2 we have some of those titles transposed on the first row. The task is to find all possible values for each title in sheet 2. Let's say in sheet 2 on the first cell we have title X, then I need to find all values corresponding to title X in sheet 1 and to take out the results from the 8th column of sheet 1. then do the same for cell 2 in sheet 2 and so on till the end of the row.
Can someone share a hint or any suggestions that might help me.
Actually I used the following code:
Sheets("sheet2").Select
Dim Lcola As Long
Dim rng As Range
With ActiveSheet
Lcola = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set rng = .Range(.Cells(2, 1), .Cells(2, Lcola))
With rng
Range("A2").Select
ActiveCell.Formula = "=VLOOKUP(A$1,MAP!$A$1:$I$" & lRowc & _
",8,FALSE)"
Selection.AutoFill Destination:=rng, Type:=xlFillDefault
End With
End With
The thing is that I'm not sure how to repeat the function several times, or as much repetitions as I have on each variable from sheet 2 in sheet 1. And another issue that I'm facing is the vlookup function always gives me the first found item.
Use a For loop, with your last Column from Sheet2 as your counter Max.
use iCol to keep track of which Column on Sheet2 you are copying and reading from.
use iRow to keep track of which ROW has the data you want on Sheet1.
Since you know you need the 8th column on the Sheet 1, it will always be Sheets("Sheet1"),Cells(iRow, 8)
and since you know the ROW that the column headers are located in Sheet2, Sheets("Sheet2"),Cells( 1, iCol) - if the header row is 1.
Then just grab a LastRow check on the Sheet2 Column in question and add to it one at a time.
Dim iCol As Integer
Dim lastCol As Integer
Dim lastRow1 As Integer
Dim lastRow2 As Integer
Dim matchRow As Integer
Dim tempVal As String
Dim iRow As Integer
Dim nRow As Integer
Private Sub IndexMatchLoop()
lastCol = Sheets("Sheet2").Cells(1, Columns.Count).End(xlToLeft).Column
For iCol = 1 To lastCol
'Assuming your row on Sheet2 is 1.
tempVal = Sheets("Sheet2").Cells(1, iCol)
iRow = 1
Call GetLastRow
nRow = lastRow2 + 1
'Looks up the value from Sheet2 Column Header on Column1 of Sheet1 one Row at a Time
For iRow = 1 to lastRow1
If Sheets("Sheet1").Cells(iRow, 1) = tempVal Then
'Copy the data from Sheet1 Column 8 in the Rows with the value to Sheet2, the nextRow of the Col
Sheets("Sheet2").Cells(nRow, iCol) = Sheets("Sheet1").Cells(iRow, 8)
nRow = nRow + 1
End If
Next iRow
Next iCol
End Sub
Private Sub GetLastRow()
lastRow1 = Sheets("Sheet1").Cells(65532, 1).End(xlUp).Row
lastRow2 = Sheets("Sheet2").Cells(65532, iCol).End(xlUp).Row
End Sub
EDIT: typo in formula (was relying on autoComplete for "Int" instead of "Integer"
EDIT: Adding Screenshots