I'm trying to create a macro to copy data from worksheet A to worksheet B.
Worksheet A is just filled with data without any layout.
Worksheet B has a particular layout in which the data of worksheet A should be pasted.
Worksheet B has a header in the first 10 rows, so the copying should start at row 11. Data in worksheet A start at row 2. So row2(A)=>row11(B), row3(A)=>row12(B),...
The code for this part of the problem included below.
The condition I'm struggling with is that only rows without a value in colum F in worksheet B should be used.
So par example if rows 11-61 in worksheet B have no value in column F, rows 2-52 of worksheet A should be pasted in rows 11-61 in worksheet B. If cell F62 isn't empty, that row should be skipped en the next row of worksheet A (row 52) should be pasted in row 63 in worksheet B. And so on, till the next row with data in column F.
The code so far:
Sub RO()
'
' RO Macro
'
' Sneltoets: Ctrl+Shift+S
'
Dim a As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("SO")
Set Target = ActiveWorkbook.Worksheets("RO")
j = 11 ' Start copying to row 11 in target sheet
For Each a In Source.Range("A2:A10000") ' Do 10000 rows
If a <> "" Then
Source.Rows(a.Row).Copy Target.Rows(j)
Target.Rows(j).Value = Source.Rows(a.Row).Value
j = j + 1
End If
Next a
Thanks in advance!
I usually use this piece of code to copy paste values.
its pretty quick
Public Sub Copy()
Dim Source As Worksheet
Dim SourceRow As Long
Dim SourceRange As String
Dim Target As Worksheet
Dim TargetRow As Long
Dim TargetRange As String
Dim ColumnCount As Long
Set Source = ActiveWorkbook.Worksheets("Blad1")
Set Target = ActiveWorkbook.Worksheets("Blad2")
TargetRow = 11
ColumnCount = Source.UsedRange.Columns.Count
For SourceRow = 1 To Source.UsedRange.Rows.Count
SourceRange = Range(Cells(SourceRow, 1), Cells(SourceRow, ColumnCount)).Address
While Target.Cells(TargetRow, 6).value <> ""
TargetRow = TargetRow + 1
Wend
TargetRange = Range(Cells(TargetRow, 1), Cells(TargetRow, ColumnCount)).Address
Target.Range(TargetRange).Value = Source.Range(SourceRange).Value
TargetRow = TargetRow + 1
Next
End Sub
Try using 2 separate counts, 1 to keep track of the source rows you are trying to copy, and another to keep track of the target rows you are trying to paste. then you can increment them independently depending if a row passes a criteria etc.
If you are pasting blocks have 2 sets of row counts: source start & source end, paste start & paste end. Not fancy, but allows max control and processing of exceptions etc.
Related
I am working on a tool to build a stored procedure based on the available prices getting directly from vendor. As per the attached snap, I paste all the rics (identifier) under column I and put the number of days in cell B2 (let's say I am looking for last 300 days of historical prices for STIM.OQ, VOD.L (vodafone) and AAPL.OQ (Apple Inc).
Currently this tool only fetches the prices for a single ric based on the cell value A2, I wanted to put this in a loop so that whatever rics I paste in column I go through that loop and the code should copy the stored procedure from column F and append it to a new single sheet for each of the rics.
Note: the stored procedure takes the value from cell B8, D8 and E8
Use ws.Cells(Rows.Count, "I").End(xlUp).Row to find the last row and then loop through starting at row 2.
Option Explicit
Sub CreateProcs()
Dim wb As Workbook, ws As Worksheet, wsRic As Worksheet
Dim iLastRow As Long, r As Long, n As Long, i As Integer
Dim ric As String
Set wb = ThisWorkbook
Set ws = wb.Sheets(1) ' as appropriate
n = ws.Range("B2").Value ' days
' loop through rics in col I
iLastRow = ws.Cells(Rows.Count, "I").End(xlUp).Row
For r = 2 To iLastRow
ric = ws.Cells(r, "I")
ws.Range("A2").Value2 = ric
' create sheet
Set wsRic = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
wsRic.Name = ric
' copy data
wsRic.Range("A1:A" & n).Value2 = ws.Range("F8").Resize(n).Value2
i = i + 1
Next
MsgBox i & " sheets created", vbInformation
End Sub
I am looking to deal with a couple of problems here:
We have a spreadsheet from a client that consists of 150 odd tabs of the same daily work form. In each work form, thankfully in the same positions, are a date in C4 and a list of works carried out starting in B10.(the works carried out vary in a number of cells; some have 3 some have 8 etc... so a list
redacted sheet, partial
What I need to do is, copy the works carried out into the database sheet, Column B, then copy the date from C4 (in the works sheet) into column A (of the database sheet), for each one of the works carried out. (so if there are 5 tasks carried out it would copy in the date to Column A 5 times. I then need to do that for all the tabs, so it is in one list.
There is a gap below the list of works of 1 cell then more data, this is the same above... noit sure if End(xlUp) or End(xldown)would be usable.
multiple tabs macro - the issue is it copies to each tab, not a single tab
Sub DateCLM()
DateCLM Macro
Date Column
Dim xSh As Worksheet
Application.ScreenUpdating = False
For Each xSh In Worksheets
xSh.Select
Call RunCode
Next
Application.ScreenUpdating = True
End Sub
Currently trying to figure this out and not getting anywhere.. any help would be appreciated.
Matt
How can I copy a column of cells in excel, with VBA, until there is a
blank and paste it into a new sheet?
Here is an algorithm I came up with years ago to solve this problem.
Create variables for the first and last cells in your range
Set the value of the first cell in the range, i.e. B10
Select the first cell in the range
While active cell is not empty
select the next cell down
end while
select the range of cells between your two variables
---perform some action---
I don't have access to the original file, nor have I used VBA for years, but I've given it a go. Hopefully this will give you a help in the right direction?
Sub selectRange()
'Create variables for the first and last cells in your range
Dim firstCell As Range
Dim lastCell As Range
'Set the value of the first cell in the range, i.e. B10
firstCell = Range("B10")
'Select the first cell in the range
firstCell.Select
firstCell.Activate
'Loop while cell is empty
While Not ActiveCell = ""
ActiveCell.Offset(1, 0).Activate
Wend
'After empty cell is found, activate last non-empty cell
ActiveCell.Offset(-1, 0).Activate
lastCell = ActiveCell
'Select the range of cells between your two variables
ActiveSheet.Range(firstCell, lastCell).Select
'---perform some action---
End Sub
Copy From Multiple Worksheets
It is assumed that the data is consistent:
Database is a worksheet in the same workbook as the worksheets to be processed,
all dates are in cell C4 and are actual dates,
all other data is located from cell B10 to before (above) the first blank cell below.
Adjust the values in the constants section.
The Code
Option Explicit
Sub copyFromMultipleWorksheets()
Const wsName As String = "Database"
Const wsCell As String = "A2"
Const datesCell As String = "C4"
Const worksFirstCell As String = "B10"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsCount As Long: wsCount = wb.Worksheets.Count
' Define Arrays.
Dim Works As Variant: ReDim Works(1 To wsCount - 1)
Dim Dates() As Date: ReDim Dates(1 To wsCount - 1)
Dim RowsCount() As Long: ReDim RowsCount(1 To wsCount - 1)
Dim OneValue As Variant: ReDim OneValue(1 To 1, 1 To 1)
' Declare additional variables.
Dim ws As Worksheet ' Source Worksheet
Dim rg As Range ' Source Range
Dim rCount As Long ' Rows Count
Dim tRows As Long ' Total Rows (for Data Array)
Dim n As Long ' Worksheets, Dates, Works Arrays, RowCounts Counter
For Each ws In wb.Worksheets
If ws.Name <> wsName Then
' Define Works Range.
With ws.Range(worksFirstCell)
Set rg = .Resize(.Worksheet.Rows.Count - .Row + 1)
Set rg = rg.Find("", rg.Cells(rg.Rows.Count), xlFormulas)
Debug.Print rg.Address
Set rg = .Resize(rg.Row - .Row)
End With
' Count, write date and count some more.
n = n + 1
Dates(n) = ws.Range(datesCell).Value
rCount = rg.Rows.Count
RowsCount(n) = rCount
tRows = tRows + rCount
' Write values from Works Range to current array of Works Array.
If rCount > 1 Then
Works(n) = rg.Value
Else
Works(n) = OneValue: Works(n)(1, 1) = rg.Value
End If
End If
Next ws
' Write values from arrays of Works Array to Data Array.
Dim Data As Variant: ReDim Data(1 To tRows, 1 To 2)
Dim i As Long, k As Long
For n = 1 To n
For i = 1 To RowsCount(n)
k = k + 1
Data(k, 1) = Dates(n)
Data(k, 2) = Works(n)(i, 1)
Next i
Next n
' Write values from Data Array to Destination Range.
With wb.Worksheets(wsName).Range(wsCell).Resize(, 2)
Application.ScreenUpdating = False
.Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
.Resize(k).Value = Data
Application.ScreenUpdating = True
End With
' Inform user.
MsgBox "Data transferred.", vbInformation, "Success"
End Sub
I have an Excel table which may contain such:
Screenshot of content from a table, columns C and D
It may be much longer
on top of column D may be an empty cell, but after that it is always the same sequence of contents repeating.
I want to copy and paste in another sheet, with transpose, the contents of the neighboring cells, that is in C, so it would look like:
a screenshot from destination table
It is easy to copy the header, but I am completely unable to have the code loop through and copy all the column C contents that appear left to what is between 1tst and 27tst in the original column D, until all of the blocks of data are copied.
To complicate things even further, I want all empty cells in this destination table to take the value from the cell above, basically filling the blanks that way. This would then look like
Final look of the destination table
In this example, the Words "Algeria | DZ" have to be automatically copied down. The cell under "24tst" remains blank as there is nothing but the header preceding this row.
I have absolutely no starting code here, as these data already made a long process from a Word file through a csv using Ruby, and then the csv is read in and reformatted into various sheets in the Excel file with already long line sof code. That all works so far, but these are my missing steps.
Any help is greatly appreciated. I only started coding again 3 weeks ago, after having never programmed in VBA but years ago in perl and R.
-- In response to VBasic2008 and to try that out I made now a test spreadsheet that looks this way:this is closer to what it really looks like
I changed the constants here:
enter code hereConst sName As String = "Tabelle1" ' Source Worksheet Name
enter code hereConst sFirst As String = "C2" ' Source First Cell Address
enter code hereConst tName As String = "Tabelle2" ' Target Worksheet Name
enter code hereConst tFirst As String = "B1" ' Target First Cell Address
The groups will actually be constant in length, actually more than 11, but that can be fixed later.
These:
1tst
2tst
3tst
11tst
4tst
22tst
23tst
24tst
25tst
26tst
27tst -
I pasted this already into target sheet.
What I get from my test using my thus modified solution from VBasic2008 is this:
Afghanistan | AF Åland Islands | AX Albania | AL Algeria | DZ American Samoa | AS Belgium | BE Belize | BZ 24tst Bermuda | BM Bhutan | BT Bolivia | BO
Bonaire, Sint Eustatius and Saba | BQ Bosnia and Herzegovina | BA Botswana | BW Algeria | DZ Brazil | BR Christmas Island | CX Cocos (Keeling) Islands | CC Colombia | CO Comoros | KM n/a Congo | CD
This is almost perfect, except for it should not, in the first row in the target sheet after the headers, copied down the "24tst". Can this still be tweaked?
A Copy Transpose
This will work correctly only if the data is consistent i.e. 11 rows of data and 1 empty (Next-Group) row (can be changed in the constants section) i.e. if you have 5 data sets, there has to be 60 rows of data. If there is 65, only 60 will be processed and if there is 59, only 48 will be processed.
The following image shows what the current setup in the code will produce (without the formatting).
The Code
Option Explicit
Sub transposeData()
Const sName As String = "Sheet1" ' Source Worksheet Name
Const sFirst As String = "A2" ' Source First Cell Address
Const tName As String = "Sheet1" ' Target Worksheet Name
Const tFirst As String = "D1" ' Target First Cell Address
Const NoE As Long = 11 ' Number of Elements
Const NoER As Long = 1 ' Number of Empty Rows
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
' Define Source Worksheet ('ws').
Dim ws As Worksheet
Set ws = wb.Worksheets(sName)
' Define Source First Cell ('First').
Dim First As Range
Set First = ws.Range(sFirst)
' Define Source Last Cell ('Last').
Dim Last As Range
Set Last = First.Offset(ws.Rows.Count - First.Row, 1).End(xlUp)
If Last.Row - First.Row + 1 < NoE Then
GoTo ProcExit
End If
' Define Source Range ('rng').
Dim rng As Range
Set rng = ws.Range(First, Last)
' Write values from Source Range to Source Array ('Source').
Dim Source As Variant
Source = rng.Value
' Define number of Data Sets ('NoDS').
Dim NoDS As Long
NoDS = Int(UBound(Source, 1) / (NoE + NoER))
' Define Target Number of Rows ('NoR').
Dim NoR As Long
NoR = NoDS + 1
' Define Target Array ('Target').
Dim Target As Variant
ReDim Target(1 To NoR, 1 To NoE)
' Declare additional variables for the upcoming loops.
Dim CurrentValue As Variant ' Source Current Value
Dim CurrentLR As Long ' Source Current Last Row
Dim j As Long ' Target Columns Counter
Dim i As Long ' Target Rows Counter
' Write headers.
For j = 1 To NoE
Target(1, j) = Source(j, 2)
Next j
' Write data.
For i = 2 To NoR
CurrentLR = (i - 2) * (NoE + NoER)
For j = 1 To NoE
CurrentValue = Source(CurrentLR + j, 1)
If Not IsEmpty(CurrentValue) Then
Target(i, j) = CurrentValue
Else
Target(i, j) = Target(i - 1, j)
End If
Next j
Next i
' Define Target Worksheet ('ws').
Set ws = wb.Worksheets(tName)
' Define Target First Cell ('First').
Set First = ws.Range(tFirst)
' Define Target Range ('rng').
Set rng = First.Resize(NoR, NoE)
' Write values from Target Array to Target Range.
rng.Value = Target
' Inform user
MsgBox "Data transferred.", vbInformation, "Success"
ProcExit:
End Sub
EDIT
Tiny Change
Instead of Target(i, j) = Target(i - 1, j) use
If i > 2 Then
Target(i, j) = Target(i - 1, j)
End If
I think the easiest way of doing this is looping through cells with headers and checking each value.
When you find your "next-group" cell then trigger some ifs;
Example program which covers your problem below:
Sub solution()
'Set first row
Dim firstrow As Integer
firstrow = 1
'Find last row
Dim lastrow As Integer
lastrow = Cells(Rows.Count, 1).End(xlUp).Row 'Go to bottom of file and jump up to last non-empty cell
'Set first column
Dim firstcolumn As Integer
firstcolumn = 1
'find last column
Dim lastcolumn As Integer
lastcolumn = 2
'Set first cell of target table
Dim targetrange As Range
Set targetrange = Range("E2")
Dim i As Integer
Dim cnt As Integer 'conuter for creating offset (for columns)
Dim cnt2 As Integer 'conuter for creating offset (for rows)
'Copy headers
cnt = 0
For i = firstrow To lastrow
If Cells(i, lastcolumn).Value = "next-group" Then Exit For
Cells(i, lastcolumn).Copy targetrange.Offset(0, cnt)
cnt = cnt + 1
Next i
'Copy data
cnt = 0
cnt2 = 1
For i = firstrow To lastrow
'If we have text "next group"
If Cells(i, lastcolumn).Value = "next-group" Then
cnt = 0 'start with first column
cnt2 = cnt2 + 1 'Start with next row
'This cell is not copied
Else
'cell is copied
Cells(i, firstcolumn).Copy targetrange.Offset(cnt2, cnt)
'column counter is increased
cnt = cnt + 1
End If
Next i
'Change blank cells in current region into formula which points to cell one row above
'targetrange.CurrentRegion.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
'Same formula but keep cells in first row of data blank istead copying header
Dim targetArea As Range
Set targetArea = targetrange.CurrentRegion
targetArea.Offset(2).Resize(targetArea.Rows.Count - 2).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
End Sub
I didn't cover case when you have empty cell in first row as you didn't described what you're expecting (at this moment it have same formula so it will be filled with header value).
UPDATE: I didnt put "=" inside R1C1 formula, now its fixed.
UPDATE2: Changed part of filling empty cells so it skips first 2 rows (Headers and first row of data) instead filling it as mentioned in question update
I have data organized into rows and in column B I have data titles. I want to select the data after the titles and then give them range names based on that title. I was able to code a solution that could name column ranges dynamically this way, but when altering it to name the rows of data I run into a 1004 error, specifically at the rng.CreateNames point.
Sub RowNames()
Dim ws As Worksheet, firstCol As Long, lastCol As Long, rowNum As Long, r As Integer, n As Integer, rng As Range, rngName As Range
Set ws = ThisWorkbook.Sheets("MonthlySales")
Set rng = ws.Range("B2:N41")
For n = 1 To rng.Rows.Count
For r = rng.Columns.Count To 1 Step -1
rowNum = rng.Rows(n).Row
firstCol = rng.Columns(1).Column
lastCol = rng.Columns(r).Column
If Cells(firstCol, rowNum).Value <> "" Then
Set rngName = Range(Cells(firstCol, rowNum), Cells(lastCol, rowNum))
rngName.CreateNames Left:=True
Exit For
End If
Next r
Next n
End Sub
Naming Row Ranges
Range.CreateNames Method
Frankly, never heard of it. Basically, in this case, you take a range and write different names in its first column and when you loop through the rows, for each row you write something like Range("A1:D1").CreateNames Left:=True to create a named range whose name is the value in A1 and it will refer to the range B1:D1.
To mix it up, this example (I think OP also) assumes that there might be blank cells in the first column, and the number of cells in each row range may vary. Each row range will be checked backwards for a value which will define its size.
The Code
Option Explicit
Sub RowNames()
' Define worksheet.
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("MonthlySales")
' Define Source Range.
Dim rng As Range
Set rng = ws.Range("B2:N41")
' Define Columns Count.
Dim ColumnsCount As Long
ColumnsCount = rng.Columns.Count
Dim RowRange As Range ' Current Row Range
Dim r As Long ' Source Range Rows Counter
Dim c As Long ' Source Range / Current Row Range Columns Counter
' Loop through rows of Source Range.
For r = 1 To rng.Rows.Count
' Create a reference to the current Row Range.
Set RowRange = rng.Rows(r)
' Check if first cell of current Row Range contains a value,
' making it a possible candidate for a defined name.
If RowRange.Cells(1).Value <> "" Then
' Loop through cells (columns) of current Row Range backwards.
For c = ColumnsCount To 2 Step -1
' Check if current cell in current Row Range contains a value.
If RowRange.Cells(c) <> "" Then
' Create a named range from value in first cell. The range
' is defined from the second cell to to current cell
' in current Row Range.
RowRange.Cells(1).Resize(, c).CreateNames Left:=True
' Exit loop, we got what we came for (the named range).
Exit For
End If
Next c
End If
Next r
End Sub
We have two worksheets.
Source worksheet is "profes"
Target worksheet is "primaria"
The data common to both worksheets is the name column.
ie: David Smith Weston appears in both worksheets.
We need to "lookup" each students name and paste values from "profes" to "primaria". I have most of the code working already BUT I don't know how to add the "lookup" part. As you can see it's wrong.
Sub Button1_Click()
Set Source = ActiveWorkbook.Worksheets("profes")
Set Target = ActiveWorkbook.Worksheets("primaria")
j = 1 ' Start copying to row 1 in target sheet
For Each c In Source.Range("N5:R1000") ' Do 100 rows
**If Source.Cells(j, "C").Value = Target.Cells(j, "A").Value** Then
Target.Cells(j, "N").Value = Source.Cells(j, "D").Value
j = j + 1
End If
Next c
End Sub
When comparing 2 ranges between 2 worksheets, you have 1 For loop, and replace the second loop with the Match function.
Once you loop over your "profes" sheet's range, and per cell you check if that value is found within the second range in "primaria" sheet, I used LookupRng, as you can see in the code below - you will need to adjust the range cording to your needs.
Code
Option Explicit
Sub Button1_Click()
Dim Source As Worksheet, Target As Worksheet
Dim MatchRow As Variant
Dim j As Long
Dim C As Range, LookupRng As Range
Set Source = ActiveWorkbook.Worksheets("profes")
Set Target = ActiveWorkbook.Worksheets("primaria")
' set up the Lookup range in "primaria" sheet , this is just an example, modify according to your needs
Set LookupRng = Target.Range("A2:A100")
For Each C In Source.Range("N5:R1000") ' Do 100 rows
If Not IsError(Application.Match(C.Value, LookupRng, 0)) Then ' Match was successfull
MatchRow = Application.Match(C.Value, LookupRng, 0) ' get the row number from "primaria" sheet where match was found
Target.Cells(C.Row, "N").Value = Source.Cells(MatchRow, "D").Value
End If
Next C
End Sub
Use the worksheet's MATCH function to locate names from the source column C in the target's column A.
Your supplied code is hard to decipher but perhaps this is closer to what you want to accomplish.
Sub Button1_Click()
dim j as long, r as variant
dim source as worksheet, target as worksheet
Set Source = ActiveWorkbook.Worksheets("profes")
Set Target = ActiveWorkbook.Worksheets("primaria")
with source
for j = 5 to .cells(.rows.count, "C").end(xlup).row
r=application.match(.cells(j, "C").value2, target.columns("A"), 0)
if not iserror(r) then
target(r, "D").resize(1, 5) = .cells(j, "N").resize(1, 5).value
end if
next j
end with
End Sub