I am brand new to VBA and learning on my own. I want to make a code in which I type a number in a cell (E4, last worksheet) and when run the macro, go and search for all worksheets that match that number in cell F2 and then for each worksheet that match the number, copy a range (which is a column) and then paste all columns in a new worksheet (added at the end). I have try some of the code below in different ways and sometimes work and sometimes does not. Among other problems, the problem with the code below is that when it works it is only copying one column from one finding. If there is a better, more elegant way to write this ( and make it work) your help is appreciated.
Sub abc()
Dim wscount As Integer
Dim wb As Workbook
Set wb = ActiveWorkbook
wscount = wb.Worksheets.Count
k = 1
j = 1
If Worksheets(k).Range("F2").Value = Worksheets(wscount).Range("E4").Value Then
Worksheets(wscount + 1).Range(Cells(1, 1 + j), Cells(100, 1 + j)).Value = Worksheets(k).Range("F1:F100").Value
Worksheets(wscount + 1).Range(Cells(1, 1 + j), Cells(100, 1 + j)) = Worksheets(k).Range("F1:F100").Value
j = j + 1
End If
End Sub
You were not adding a new sheet and you were not looping among the sheets. Here's a way to do it:
Sub abc()
Dim wscount As Integer: wscount = Worksheets.Count
Dim j As Long, k As Long
Worksheets.Add After:=Worksheets(wscount)
For k = 1 To wscount - 1
If Worksheets(k).Range("F2").value = Worksheets(wscount).Range("E4").value Then
j = j + 1
Worksheets(wscount + 1).Columns(j).value = Worksheets(k).Columns("F").value
End If
Next
End Sub
Related
I have a column "F" in workbook1 containing some values (obtained after using some excel formulas to extract and concatenate from other columns) like
blah-rd1
blah-rd5
blah-rd6
blah-rd48do I want to do this
blah-rd100
etc
I have another column "D" in workbook2 containing values like
rndm-blah-rd1_sgjgs
hjdf-blah-rd5_cnnv
sdfhjdf-blah-rd100_cfdnnv
ect
Basically "Blah-rdxx" is always present alongwith other strings in D column of workbook2
Now, what I want to do is -
If value in D column of workbook2 contains value of F column of workbook1 Then
copy corresponding value of S column of workbook2 in H column of workbook1 (5th column)
This is where I have reached so far but it doesnt copy anything probably coz there is some problem and the outer loop is not iterating, I tried following solution Nested For Next Loops: Outer loop not iterating and added n counter but still outer loop doesn't iterate -
Sub findandcopy()
Dim r As Range
Dim f As Range
Dim i As Long
Dim j As Long
Dim w1 As Worksheet
Dim w2 As Worksheet
Dim n As Integer
Set w1 = Workbooks("Book1.xlsm").Worksheets("sheet1")
Set w2 = Workbooks("Book2.xlsx").Worksheets("sheet1")
n = 0
For i = 1 To w2.Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To w1.Cells(Rows.Count, 1).End(xlUp).Row + n
If InStr(1, w2.Cells(i, 1).Value, w1.Cells(j, 3).Value) > 0 Then
w2.Cells(i, 2).Copy (w2.Cells(j, 5))
Exit For
n = n + 1
End If
Next j
Next i
End Sub
Try this
Option Explicit
Public Sub FindAndCopy()
Const F = "F"
Const D = "D"
Const H = 2
Const S = 15
Dim ws1 As Worksheet: Set ws1 = Workbooks("Book1.xlsm").Worksheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Workbooks("Book2.xlsm").Worksheets("Sheet1")
Dim lr1 As Long: lr1 = ws1.Cells(ws1.Rows.Count, F).End(xlUp).Row
Dim lr2 As Long: lr2 = ws2.Cells(ws2.Rows.Count, D).End(xlUp).Row
Dim itm1 As Range, itm2 As Range
Application.ScreenUpdating = False
For Each itm2 In ws2.Range(ws2.Cells(1, D), ws2.Cells(lr2, D)) 'Book2
For Each itm1 In ws1.Range(ws1.Cells(1, F), ws1.Cells(lr1, F)) 'Book1
If Not IsError(itm1) And Not IsError(itm2) Then
If InStr(1, itm2.Value2, itm1.Value2) > 0 Then
itm1.Offset(, H).Formula = itm2.Offset(, S).Formula 'Book1.H = Book2.S
Exit For
End If
End If
Next
Next
Application.ScreenUpdating = True
End Sub
The original code, with explanations of functional issues:
Sub findandcopy()
Dim w1 As Worksheet, w2 As Worksheet
Dim i As Long, j As Long, n As Integer
Set w1 = Workbooks("Book1.xlsm").Worksheets("sheet1")
Set w2 = Workbooks("Book2.xlsx").Worksheets("sheet1")
n = 0
For i = 1 To w2.Cells(Rows.Count, 1).End(xlUp).Row 'for each used cell in w2.colA
For j = 1 To w1.Cells(Rows.Count, 1).End(xlUp).Row + n 'for each used cell in w1.colA
'Find the text from w1.colC (current w1 row), within cell in w2.colA (current w2 row)
If InStr(1, w2.Cells(i, 1).Value, w1.Cells(j, 3).Value) > 0 Then
'If found then copy cell in w2.colB into cell in w2.colE (current w2 row)
w2.Cells(i, 2).Copy (w2.Cells(i, 5))
Exit For 'this exits the inner For loop
n = n + 1 'this would jump over the next cell(s) in w1, but never executes
End If
Next j
Next i
End Sub
The missing indentation makes it hard to follow
There are unused variables (r, f), and w1 / w2 names can mean Workbook, or Worksheet
"Option Explicit" should be used at the top of every module
The code doesn't handle cells with errors
#N/A, #VALUE!, #REF!, #DIV/0!, #NUM!, #NAME?, or #NULL!
If you'd like a more detailed review of the code, once it's fixed you can post it on Code Review
Here is my current output that my VBscript is generating.
ID DESCRIPTION 1 RECURSIVE_ANALYSIS
CM-1 xxxxxxxxxxxx Issue A
Sub issue a
Sub issue b
Sub issue c
CM-2 yyyyyyyyyyy Issue B
Sub issue a
Sub issue b
This is following VBA code which i have designed for getting the output
Sub CellSplitter1()
Dim Temp As Variant
Dim CText As String
Dim J As Integer
Dim K As Integer
Dim L As Integer
Dim iColumn As Integer
Dim lNumCols As Long
Dim lNumRows As Long
Dim wksNew As Worksheet
Dim wksSource As Worksheet
Dim iTargetRow As Integer
iColumn = 3
Set wksSource = ActiveSheet
Set wksNew = Worksheets.Add
iTargetRow = 0
With wksSource
lNumCols = .Range("IV1").End(xlToLeft).Column
lNumRows = .Range("A65536").End(xlUp).Row
For J = 1 To lNumRows
CText = .Cells(J, iColumn).Value
Temp = Split(CText, Chr(10))
For K = 0 To UBound(Temp)
iTargetRow = iTargetRow + 1
For L = 1 To lNumCols
If L <> iColumn Then
wksNew.Cells(iTargetRow, L) _
= .Cells(J, L)
Else
wksNew.Cells(iTargetRow, L) _
= Temp(K)
End If
Next L
Next K
Next J
End With
End Sub
Here is my expected output
ID DESCRIPTION 1 RECURSIVE_ANALYSIS Issues
CM-1 xxxxxxxxxxxx Issue A Sub issue a
Sub issue b
Sub issue c
CM-2 yyyyyyyyyyy Issue B Sub issue a
Sub issue b
So, can someone help me to figure out to get the expected output.
Any help will be much appreciated.
Thank you
it seems you didn't show the whole story, so here's a guessing:
after your code place the following
With wksNew' reference 'wksNew' sheet
With .Range(.Cells(1, iColumn), .Cells(iTargetRow, iColumn)) ' reference its 'iColumn' column range from row 1 down to its last not empty one
.Insert 'insert a new column before referenced range. now the currently referenced range is one column right shifted (i.e. its in the 4th column of referenced sheet)
.Offset(, -1).Value = .Value ' copy values from referenced range one column to the left (i.e. in the newly created column)
.Offset(, -1).Replace "Sub issue*", "", lookat:=xlWhole 'clear the newly created range cells containing "Sub issue..." (hence, there remains cells with "Issue .." only)
.Replace "Issue *", "", lookat:=xlWhole 'clear the currently referenced range (i.e the one in 4th column) cells containing "Issue..." (hence, there remains cells with "Sub issue .." only)
End With
.Columns.AutoFit 'adjust your columns width
End With
Using Variant array is more simple.
Sub test()
Dim r As Long, c As Integer
Dim j As Integer
Dim k As Integer
Dim wksNew As Worksheet
Dim wksSource As Worksheet
Dim vDB, vSplit, vR()
Set wksSource = ActiveSheet
Set wksNew = Worksheets.Add
With wksSource
c = .Range("IV1").End(xlToLeft).Column
r = .Range("A65536").End(xlUp).Row
vDB = .Range("a1", .Cells(r, c))
For i = 1 To r
vSplit = Split(vDB(i, c), Chr(10))
For k = 1 To UBound(vSplit)
n = n + 1
ReDim Preserve vR(1 To c + 1, 1 To n)
If k = 1 Then
For j = 1 To c - 1
vR(j, n) = vDB(i, j)
Next j
vR(c, n) = vSplit(k - 1)
vR(c + 1, n) = vSplit(k)
Else
vR(c + 1, n) = vSplit(k)
End If
Next k
Next i
End With
Range("a1").Resize(1, c + 1) = Array("ID", "DESCRIPTION 1", "RECURSIVE_ANALYSIS", "Issues")
Range("a2").Resize(n, c + 1) = WorksheetFunction.Transpose(vR)
End Sub
Here is the sample of my current output which the VBscript code is generating.
[https://i.stack.imgur.com/kMpih.png] [1]:
Here is the sample of my expected output
[[1]: https://i.stack.imgur.com/StBqx.png]
Please let me know your suggestions.
Thank you
I want to randomly select 50 rows from one sheet and pasting them in a separate workbook for data sampling. I don't know how to do it because first, I'm new to VBA, I want to learn something new and second, I tried searching this on Google but no accurate answer found.
So what's on my mind is this:
I'll get first the number of rows in that worksheet. I've already
done it with this one line of code:
CountRows = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
Get a random number from 1 to CountRows uniquely. The random numbers should be incremental (1,5,7,20,28,30,50 and no backward counting). Then grab that row, create a new workbook if not yet open and paste it there.
How can I achieve this process? I have no idea how to start this.
First, generate an array of 50 unique numbers between 1 and CountRows, using this routine:
' Generate a sorted array(0 to count-1) numbers between a and b inclusive
Function UniqueRandom(ByVal count As Long, ByVal a As Long, ByVal b As Long) As Long()
Dim i As Long, j As Long, x As Long
ReDim arr(b - a) As Long
Randomize
For i = 0 To b - a: arr(i) = a + i: Next
If b - a < count Then UniqueRandom = arr: Exit Function
For i = 0 To b - a 'Now we shuffle the array
j = Int(Rnd * (b - a))
x = arr(i): arr(i) = arr(j): arr(j) = x ' swap
Next
' After shuffling the array, we can simply take the first portion
ReDim Preserve arr(0 To count - 1)
'sorting, probably not necessary
For i = 0 To count - 1
For j = i To count - 1
If arr(j) < arr(i) Then x = arr(i): arr(i) = arr(j): arr(j) = x ' swap
Next
Next
UniqueRandom = arr
End Function
Now you can use the above routine to generate random, unique and sorted indexes and copy the corresponding rows. Here's an example:
Sub RandomSamples()
Const sampleCount As Long = 50
Dim lastRow As Long, i As Long, ar() As Long, rngToCopy As Range
With Sheet1
lastRow = .Cells(.Rows.count, "A").End(xlUp).row
ar = UniqueRandom(sampleCount, 1, lastRow)
Set rngToCopy = .Rows(ar(0))
For i = 1 To UBound(ar)
Set rngToCopy = Union(rngToCopy, .Rows(ar(i)))
Next
End With
With Workbooks.Add
rngToCopy.Copy .Sheets(1).Cells(1, 1)
.SaveAs ThisWorkbook.path & "\" & "samples.xlsx"
.Close False
End With
End Sub
Following code will do what you need.
Sub Demo()
Dim lng As Long
Dim tempArr() As String
Dim srcWB As Workbook, destWB As Workbook
Dim rng As Range
Dim dict As New Scripting.Dictionary
Const rowMax As Long = 100 'maximum number of rows in source sheet
Const rowMin As Long = 1 'starting row number to copy
Const rowCopy As Long = 50 'number of rows to copy
Dim intArr(1 To rowCopy) As Integer, rowArr(1 To rowCopy) As Integer
Set srcWB = ThisWorkbook
'get unique random numbers in dictionary
With dict
Do While .Count < rowCopy
lng = Rnd * (rowMax - rowMin) + rowMin
.Item(lng) = Empty
Loop
tempArr = Split(Join(.Keys, ","), ",")
End With
'convert random numbers to integers
For i = 1 To rowCopy
intArr(i) = CInt(tempArr(i - 1))
Next i
'sort random numbers
For i = 1 To rowCopy
rowArr(i) = Application.WorksheetFunction.Small(intArr, i)
If rng Is Nothing Then
Set rng = srcWB.Sheets("Sheet1").Rows(rowArr(i))
Else
Set rng = Union(rng, srcWB.Sheets("Sheet1").Rows(rowArr(i)))
End If
Next i
'copy random rows, change sheet name and destination path as required
Set destWB = Workbooks.Add
With destWB
rng.Copy destWB.Sheets("Sheet1").Range("A1")
.SaveAs Filename:="D:\Book2.xls", FileFormat:=56
End With
End Sub
Above code uses Dictionary so you have to add reference to Microsoft Scripting Runtime Type Library. In Visual Basic Editor, go to Tools->References and check "Microsoft Scripting Runtime" in the list.
Let me know if anything is not clear.
I'm writing an excel VBA script to loop through a set of 4 sheets, find a string at the top of a column of data, loop through all the data in that column and print the header and data in a summary tab.
I'm new to VBA and even after extensive research can't figure out why I'm getting Runtime error 1004 "Application-defined or object-defined error."
Here is the VBA code:
Private Sub CommandButton1_Click()
Dim HeaderList(1 To 4) As String, sheet As Worksheet, i As Integer, j As Integer, Summary As Worksheet
'Define headers to look for
HeaderList(1) = "Bananas"
HeaderList(2) = "Puppies"
HeaderList(3) = "Tigers"
'Loop through each sheet looking for the right header
For Each sheet In Workbooks("Tab Extraction Test.xlsm").Worksheets
i = i + 1
'Debug.Print i
'Debug.Print HeaderList(i)
Set h = Cells.Find(What:=HeaderList(i))
With Worksheets("Summary")
Worksheets("Summary").Cells(1, i).Value = h
End With
Col = h.Column
Debug.Print Col
Row = h.Row
Debug.Print Row
j = Row
'Until an empty cell in encountered copy the value to a summary tab
Do While IsEmpty(Cells(Col, j)) = False
j = j + 1
V = Range(Col, j).Value
Debug.Print V
Workbooks("Tab Extraction Test.xlsm").Worksheets("Summary").Cells(j, i).Value = V
Loop
Next sheet
End Sub
The error occurs at
Worksheets("Summary").Cells(1, i).Value = h
From other posts I thought this might be because I was trying to add something to a different cell than the one that was active in the current loop so I added a With statement but to no avail.
Thank you in advance for your help.
Following the comments above, try the code below.
Note: I think your Cells(Row, Col) is mixed-up, I haven't modified it yet in my answer below. I think Cells(Col, j) should be Cells(j, Col) , no ?
Code
Option Explicit
Private Sub CommandButton1_Click()
Dim HeaderList(1 To 4) As String, ws As Worksheet, i As Long, j As Long, Summary As Worksheet
Dim h As Range, Col As Long
'Define headers to look for
HeaderList(1) = "Bananas"
HeaderList(2) = "Puppies"
HeaderList(3) = "Tigers"
' set the "Summary" tab worksheet
Set Summary = Workbooks("Tab Extraction Test.xlsm").Worksheets("Summary")
'Loop through each sheet looking for the right header
For Each ws In Workbooks("Tab Extraction Test.xlsm").Worksheets
With ws
i = i + 1
Set h = .Cells.Find(What:=HeaderList(i))
If Not h Is Nothing Then ' successful find
Summary.Cells(1, i).Value = h.Value
j = h.Row
'Until an empty cell in encountered copy the value to "Summary" tab
' Do While Not IsEmpty(.Cells(h.Column, j))
Do While Not IsEmpty(.Cells(j, h.Column)) ' <-- should be
j = j + 1
Summary.Cells(j, i).Value = .Cells(j, h.Column).Value
Loop
Set h = Nothing ' reset range object
End If
End With
Next ws
End Sub
Try this one.
Private Sub CommandButton1_Click()
Dim HeaderList As Variant, ws As Worksheet, i As Integer, j As Integer, Summary As Worksheet
Dim lastRow As Long, lastCol As Long, colNum As Long
HeaderList = Array("Bananas", "Puppies", "Tigers", "Lions")
For Each ws In Workbooks("Tab Extraction Test.xlsm").Worksheets
lastCol = ws.Range("IV1").End(xlToLeft).Column
For k = 1 To lastCol
For i = 0 To 3
Set h = ws.Range(Chr(k + 64) & "1").Find(What:=HeaderList(i))
If Not h Is Nothing Then
lastRow = ws.Range(Chr(h.Column + 64) & "65536").End(xlUp).Row
colNum = colNum + 1
' The below line of code adds a header to summary page (row 1) showing which workbook and sheet the data came from
' If you want to use it then make sure you change the end of the follpowing line of code from "1" to "2"
' ThisWorkbook.Worksheets("Summary").Range(Chr(colNum + 64) & "1").Value = Left(ws.Parent.Name, Len(ws.Parent.Name) - 5) & ", " & ws.Name
ws.Range(Chr(h.Column + 64) & "1:" & Chr(h.Column + 64) & lastRow).Copy Destination:=ThisWorkbook.Worksheets("Summary").Range(Chr(colNum + 64) & "1")
Exit For
End If
Next i
Next k
Next ws
End Sub
Sometimes you have to remove blank sheets. Say you have 2k sheets because you combined a bunch of txt files into one workbook. But they're all in one column. So you loop through to do a text2columns. It does some of them but not all of them. It stops to give you run-time error 1004. Try removing blank sheets before looping through to do text2columns or something else.
Sub RemoveBlankSheets_ActiveWorkbook()
'PURPOSE: Delete any blanks sheets in the active workbook
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
Dim sht As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sht In ActiveWorkbook.Worksheets
If WorksheetFunction.CountA(sht.Cells) = 0 And _
ActiveWorkbook.Sheets.Count > 1 Then sht.Delete
Next sht
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I have the following code that looks to the original worksheet on row 80 of each column and if it has the text "True" it copies that column to the destination worksheet. It then loops and goes through all of the columns. It works perfect, except I can not figure out how to copy the column widths. - Jordan
'Called from AddWorksheet
Sub CopyFinal(orgSheet As Worksheet, destSheet As Worksheet)
Dim j As Integer '**Why is j an Integer and others are Long?
Dim lastColumn As Long
Dim benRow As Long
j = 2
lastColumn = 2
'Counts the number of benefits on each sheet. Assumes that they will not go past row 40
benRow = WorksheetFunction.CountA(orgSheet.Range("B3:B40"))
Application.ScreenUpdating = False
Do Until IsEmpty(orgSheet.Cells(3, j))
If orgSheet.Cells(80, j) = True Then
orgSheet.Cells(3, j).Resize(benRow).Copy destSheet.Cells(3, lastColumn) '**Need to paste column widths
End If
j = j + 1
lastColumn = destSheet.UsedRange.Columns(destSheet.UsedRange.Columns.Count).Column + 1
Loop
Application.ScreenUpdating = True
End Sub
Do Until IsEmpty(orgSheet.Cells(3, j))
If orgSheet.Cells(80, j) = True Then
orgSheet.Cells(3, j).Resize(benRow).Copy
With destSheet.Cells(3, lastColumn)
.Paste
.PasteSpecial Paste:=xlPasteColumnWidths
End With
End If
j = j + 1
lastColumn = destSheet.UsedRange.Columns(destSheet.UsedRange.Columns.Count).Column + 1
Loop