Posts by 7absinth

Wow. I didn't expect it will be so complicated script. However I found an error in extraction sheet, where B values with 0 in the front are disappeared:

I formatted entire sheet as text and after that B column values were shown correctly.

Thanks a lot!

This is very simple, but I am still struggling how to write the script correctly. So I have a table that have information in multiple columns in following layout

The goal is find the correct VBA routine to cut/extract data from columns to rows in following layout, keeping only table title in another sheet:

Maybe there are the solution?

Very appreciate any help.

Thanks

Thanks a lot, Barry. I tested it and just noticed small errors under:

If x = 21 Then
                x = [B][COLOR=#FF8C00]2[/COLOR][/B]
                c = c + 1
            End If

But overall works well. Also needed to change this part too:

With Me        
[B][COLOR=#FF0000].Columns.Delete[/COLOR][/B]

because it doesnt delete colors when sheet list is reduced. Again thanks so much for your time. I will subscribe to your profile and like your post.

God bless you.

Quote from iwrk4dedpr

you can attach a sample workbook. that has your current code. I see what you want now .... give me a sample workbook to work with will make assisting easier.

Sample added.

I have a following code that list and link all my worksheets in one long list. Now I come to the fact that this linked list is too long to me and I wonder if it's possible to split long linked lists into columns. I have seen separate codes that just copy out the values and split list into columns but in my case I want these cells linked too. So I am stuck and no idea how to implement code in this macro. Below is my macro.

Private Sub Worksheet_Activate()


Dim xSheet As Worksheet, x As Long, xName As Name


Application.ScreenUpdating = False


Me.Move Before:=Sheets(1)
x = 1


    With Me
        .Columns(1).ClearContents
        .Cells(1, 1) = "INDEX"
        .Cells(1, 1).Name = "INDEX"
        .Cells(1, 1).Font.Bold = 1
        .Cells(1, 1).Borders(xlEdgeBottom).LineStyle = xlDouble
    End With


    For Each xSheet In Worksheets
        If xSheet.Name <> Me.Name Then
            x = x + 1
            With xSheet
                ' Uncomment for the first use and launch. The comment again.
'                 .Rows("1:1").Insert Shift:=xlUp
'                 .Rows("1:1").Clear
                .Range("A1").Name = "_" & .Name
                .Hyperlinks.Add Anchor:=.Range("A1"), Address:="", SubAddress:="INDEX", TextToDisplay:="Back to Index"
                .Range("A1").Font.ColorIndex = xlAutomatic
                .Range("A1").Font.Bold = 1
                Me.Hyperlinks.Add Anchor:=Me.Cells(x, 1), Address:="", SubAddress:="_" & .Name, TextToDisplay:=.Name
                Me.Cells(x, 1).Font.Underline = xlUnderlineStyleNone
                Me.Cells(x, 1).Font.ColorIndex = xlAutomatic
                Me.Cells(x, 1).Font.Bold = 1
            End With
        End If
'       Me.Columns(1).AutoFit
    Next xSheet


Application.ScreenUpdating = True


End Sub

How to do that?

Its works!! Nice shot! Thanks a lot! I liked your post.

Quote from Mumps

Try:

Code

Sub AddListValuesInSheets()
Dim xRg As Range, sh As Worksheet
Set dbrange = Application.InputBox("Range: ", "Select Range", Application.Selection.Address, Type:=8)
Application.ScreenUpdating = False
For Each sh In ActiveWorkbook.Worksheets
For Each xRg In dbrange
sh.Range(xRg.Address) = xRg.Value
Next xRg
Next sh
Application.ScreenUpdating = True
End Sub

Display More

It is not what I am looking for and it doesnt work correctly.

Again - I have a vertical list with values ie A1, A2, A3. I want these values pasted/distributed in each sheet in cell D3 separately. This means to paste next value from the list in n-sheet cell D3- ie in Sheet2 in cell D3 will be value A1, in Sheet3 in cell D3 will be value A2 and in Sheet4 in cell D3 will be value A3 and so on.

I have a list with values and I want to copy and paste each value in each sheet in the same location. I tried to create code by myself and searched information but I am still stuck to figure out how to do this.

Below is code.

Sub AddListValuesInSheets()


Dim xRg As Range, sh As Worksheet


On Error GoTo Quit
Set dbrange = Application.InputBox("Range: ", "Select Range", _
Application.Selection.Address, Type:=8)
    
Application.ScreenUpdating = False


For Each xRg In dbrange
    For Each sh In ActiveWorkbook.Worksheets
        sh.Range("D3").Value = xRg.Value
    Next sh
Next xRg
    
Application.ScreenUpdating = True
Quit:


End Sub

Where is the problem? This code go through all sheets to paste the LAST cell from the list. And this is not that I want.

Quote from Luke M

Try it like this

This is amazing how few lines were needed. Works as charming. You are my wizard Luke. :cool: Thanks a lot.

I only deleted wSheet in your lines, because there are With wSheet operator already.

I could not to find the best thread for my issue anywhere.

I have a following code (see below) that Index sheets dynamically. Now is a problem to implement the code that color Index cells when I color that tab. For example when I color T1 tab in green it will color relevant cell in the INDEX tab. In this example it will be A2. When I color T3 tab code will color A3 cell in the INDEX tab and so on. See picture.

[VBA]Private Sub Worksheet_Activate()

Dim wSheet As Worksheet, l As Long

Application.ScreenUpdating = False

Me.Move Before:=Sheets(1)
l = 1

With Me
.Columns(1).ClearContents
.Cells(1, 1) = "INDEX"
.Cells(1, 1).Name = "Index"
.Cells(1, 1).Font.Bold = 1
End With

For Each wSheet In Worksheets
If wSheet.Name <> Me.Name Then
l = l + 1
With wSheet
' Uncomment for the first time then comment again
' .Rows("1:1").Insert Shift:=xlUp
' .Rows("1:1").Clear
.Range("A1").Name = "Start_" & .Index
.Hyperlinks.Add Anchor:=.Range("A1"), Address:="", _
SubAddress:="Index", TextToDisplay:="Back to Index"
.Range("A1").Font.ColorIndex = xlAutomatic
Me.Hyperlinks.Add Anchor:=Me.Cells(l, 1), Address:="", _
SubAddress:="Start_" & .Index, TextToDisplay:=wSheet.Name
End With
End If
Me.Columns(1).AutoFit
Next wSheet

Application.ScreenUpdating = True

End Sub[/VBA]

[ATTACH=JSON]{"alt":"Click image for larger version Name:\tSample.JPG Views:\t1 Size:\t24.1 KB ID:\t1193524","data-align":"none","data-attachmentid":"1193524","data-size":"full","title":"Sample.JPG"}[/ATTACH]

Re: Sum from two Tables based on From-To Date criteria

<p>
Work like a charm. God bless you.</p>

I have two spreadsheets that are in two tables. In each tab is same table format. And here is the problem. In each table has date and data column. And I just try to create a formula that sums values between two dates where the first date is the oldest date that I dont want to enter (so it must to be in formula) and date that I input manually. So only one criteria (TO date) need to enter, but I am confused how to calculate from two tables if sumif sumproduct and sum doesnt work as I expected. Is this possible in general to resolve? I have attached a sample.

Re: Insert No linked picture in the cell with formatting VBA

Seems I found the solution. Thank you for your help.:thumbcoo:

I wrote the following lines:

With pic
            .LockAspectRatio = msoFalse
            .Placement = xlMoveAndSize
        End With

AND gotcha.

Re: Insert No linked picture in the cell with formatting VBA

Nice idea to define as shape but I mean this picture in the cell. Macro works but it doesnt stretch with the cell (LockAspectRatio) as it's when pic variable define as picture. And here I am stuck.

I found the difficulties to find the right approach in Excel HOW I can to format inserted object (picture) with line borders and colors etc.

Option Explicit
Sub ImportPictureNoLinked()




Dim fd As Office.FileDialog, pic As Object




Set fd = Application.FileDialog(msoFileDialogFilePicker)




With fd
.AllowMultiSelect = False
.Title = "Please select the file"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
.FilterIndex = 2




If .Show = -1 Then




Set pic = ActiveSheet.Shapes.AddPicture(Filename:=.SelectedItems(1), LinkToFile:=False, _
SaveWithDocument:=True, Left:=ActiveCell.Left, Top:=ActiveCell.Top, _
Width:=ActiveCell.Width, Height:=ActiveCell.Height)




'<HERE I WANT A CODE THAT MAKE INSERTED PICTURE BORDER LINE WITH COLOR AND DISABLE LOCK ASPECT RATIO>




Set pic = Nothing




End If
End With
End Sub

Re: Count Chars/Words from Comments and TextBox VBA

Quote from pike;771171

[/CODE]

WOW. Really WOW. I am impressed. You are like macro magician :wowee:. Now its works as my wall clock.:congrats:

Re: Count Chars/Words from Comments and TextBox VBA

Quote from pike;771152

and shortened [..]
End Sub[/CODE]

I didnt think of about type for this part. All looks cool till I encountered it doesnt count TxtBox Words correctly. Now its counts TxtBox as Object. I added 1 text box and it counts as 1 word. No matter how many words are written inside.

Re: Count Chars/Words from Comments and TextBox VBA

From the post #11. Same error on the line:
If TypeName(shp) <> "GroupObject" And shp.TextFrame2.TextRange.Characters.Text <> "" Then

Re: Count Chars/Words from Comments and TextBox VBA

Quote from pike;771101

all I need is an example workbook to help and you wont post workbook .. good luck

I have added the file. All comments are included in the code.

Re: Count Chars/Words from Comments and TextBox VBA

Quote from pike;771084

all depend what controls are used make a dummy example reflecting the question and attach

I have added the code on post #1 and I just need the modification that counts char/words from TxtBox and Comments. If I launch code separately (for example only for Comments) its works fine without any controls added. Same situation is with TextBox. I dont add any additional controls. Only that are provided by Default.